Télécharger la plaquette Cast3M


fr en

Télécharger jeupha.eso

Retour à la liste

Numérotation des lignes : 

jeupha

  1. C JEUPHA    SOURCE    OF166741  25/02/21    21:17:38     12166          
  2.       SUBROUTINE JEUPHA
  3.  
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7. * +------------------------------------------------------------------------+
  8. * | création des "jeux" a associer aux matrices de blocages pour le modele |
  9. * | CHANGEMENT_PHASE                                                       |
  10. * | en entrée : objet modele , MCHAML de temperature de changement         |
  11. * | de phase et temperature initiale, matrice de blocages                  |
  12. * +------------------------------------------------------------------------+
  13.  
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC CCREEL
  18.  
  19. -INC SMELEME
  20. -INC SMMODEL
  21. -INC SMCOORD
  22. -INC SMCHPOI
  23. -INC SMCHAML
  24.  
  25. -INC TMPTVAL
  26.  
  27.       SEGMENT XCPR1(nbpts,5)
  28. C      xcpr1(:,1)  : Noeud 'LX' corespondant au noeud INCO pour ivamod(2)
  29. C      xcpr1(:,2)  : Noeud 'LX' corespondant au noeud INCO pour ivamod(3) (Cas 'SOLUBILITE')
  30. C      xcpr1(:,3)  : Valeur initiale INCONNUE A
  31. C      xcpr1(:,4)  : Valeur initiale INCONNUE B (Cas 'SOLUBILITE')
  32. C      xcpr1(:,5)  : Solubilite pour le NOEUD INCONNUE A
  33.  
  34.       SEGMENT XCPR2(nbpts,2)
  35. C       XCPR2(:,1) : Pour chaque indice de noeud 'LX', 0. ou 1. pour indiquer sa presence
  36. C       XCPR2(:,2) : Pour chaque indice de noeud 'LX', la valeur du jeu
  37.  
  38.       SEGMENT NOTYPE
  39.         CHARACTER*16 TYPE(NBTYPE)
  40.       ENDSEGMENT
  41.  
  42.       PARAMETER ( NINF=3 )
  43.       INTEGER INFOS(NINF)
  44.  
  45.       CHARACTER*(LOCOMP) MPRIM1,MPRIM2
  46.       CHARACTER*(LCONMO) CONM
  47.  
  48.       LOGICAL LOG_A
  49.  
  50. * +--------------------------------------------------------------------+
  51.       ipt2  = 0
  52.       MPRIM2= ' '
  53.  
  54. C     ----------------------------------------
  55. C     Lecture du modele
  56.       call lirobj('MMODEL  ',mmode2,1,iretou)
  57.       call actobj('MMODEL  ',mmode2,1)
  58.       if(ierr.ne.0) return
  59.  
  60. C     ----------------------------------------
  61. C     Lecture du materiaux
  62.       call lirobj('MCHAML  ',IPMATR,1,iretou)
  63.       call actobj('MCHAML  ',IPMATR,1)
  64.       if(ierr.ne.0) RETURN
  65.       CALL REDUAF(IPMATR,MMODE2,MCHEL2,0,IR2,KER)
  66.       IF(IR2  .NE. 1) CALL ERREUR(KER)
  67.       IF(IERR .NE. 0) RETURN
  68. C     Changement eventuel aux noeuds
  69.       ISUP=1
  70.       CALL CHASUP(MMODE2,MCHEL2,mchelm,IRT2,ISUP)
  71.       IF(IRT2.NE.0) THEN
  72.         CALL ERREUR(IRT2)
  73.         RETURN
  74.       ENDIF
  75.       mchel2=mchelm
  76.  
  77. C     ----------------------------------------
  78. C     Lecture du CHPOINT des valeurs au depart
  79.       call lirobj('CHPOINT ',mchpo1,1,iretou)
  80.       call actobj('CHPOINT ',mchpo1,1)
  81.       if(ierr.ne.0) return
  82.  
  83. C     ----------------------------------------
  84.       SEGINI,XCPR1,XCPR2
  85.  
  86. C     Pour Komcha 1 seul SEGINI
  87.       nbtype = 1
  88.       nbrobl = 1
  89.       nbrfac = 0
  90.       segini,notype,nomid
  91.       ipnomi = nomid
  92.       notype.type(1) ='REAL*8'
  93.  
  94. C     On fait le travail
  95.       nbelem = 0
  96.       do 100 i = 1,mmode2.kmodel(/1)
  97.         inomax = 0
  98.         imodel = mmode2.kmodel(i)
  99.         nfor   = imodel.formod(/2)
  100.  
  101.         call place(imodel.formod,nfor,iplac,'CHANGEMENT_PHASE')
  102.         if (iplac .eq. 0) goto 100
  103.  
  104.         nomid  = imodel.lnomid(1)
  105.         ipt1   = imodel.ivamod(2)
  106.         MPRIM1 = nomid.lesobl(1)
  107.         IF    (imodel.matmod(1)(1:10) .EQ. 'PARFAIT   ')THEN
  108.           ICAS = 1
  109.  
  110.         ELSEIF(imodel.matmod(1)(1:10) .EQ. 'SOLUBILITE')THEN
  111.           ICAS   = 2
  112.           ipt2   = imodel.ivamod(3)
  113.           MPRIM2 = nomid.lesobl(2)
  114.  
  115.         ELSE
  116.           CALL ERREUR(5)
  117.         ENDIF
  118.  
  119.         if(i .gt. 1)then
  120. c         remise a zero des 2 premieres lignes
  121.           call zero(xcpr1(1,1),nbpts,2)
  122.         endif
  123.  
  124. C       On fait l'XCPR1 indexes par les noeuds des INCONNUES (remettre a zero a chaque sous-zones qui se partagent les noeuds primals potentiellement)
  125.         do 101 iel=1,ipt1.num(/2)
  126. c         noeud 1 : 'LX'
  127. c         noeud 2 & noeud 3 (numero de noeud egal) : 'inconnues classiques A et B'
  128.           nno    = ipt1.num(2,iel)
  129.           inomax = MAX(inomax,nno)
  130.           if(nint(xcpr1(nno,1)) .eq. 0) then
  131.             ino1        =ipt1.num(1,iel)
  132.             xcpr1(nno,1)= real(ino1)
  133.             inomax      = MAX(inomax,ino1)
  134.             if (ICAS .eq. 2)then
  135.               ino2        =ipt2.num(1,iel)
  136.               xcpr1(nno,2)= real(ino2)
  137.               inomax      = MAX(inomax,ino2)
  138.             endif
  139.           endif
  140.   101   continue
  141.  
  142. C       Recherche des valeurs dans le CHPOINT initial
  143.         do 102 isoupo=1,mchpo1.ipchp(/1)
  144.           msoup1 = mchpo1.ipchp(isoupo)
  145. C         Le 'LX' ne nous interesse pas pour le CHPOINT INITIAL
  146.           if (msoup1.nocomp(1) .EQ. 'LX      ') goto 102
  147.  
  148.           ipt1   = msoup1.igeoc
  149.           nbel1  = ipt1.num(/2)
  150.           mpova1 = msoup1.ipoval
  151.           do icmp=1,msoup1.nocomp(/2)
  152.             if    (msoup1.nocomp(icmp) .eq. MPRIM1)then
  153.               do 103 iel=1,nbel1
  154.                 nel1          = ipt1.num(1,iel)
  155.                 xcpr1(nel1,3) = mpova1.vpocha(iel,icmp)
  156.  103          continue
  157.  
  158.             elseif(msoup1.nocomp(icmp) .eq. MPRIM2)then
  159.               do 104 iel=1,nbel1
  160.                 nel1          = ipt1.num(1,iel)
  161.                 xcpr1(nel1,4) = mpova1.vpocha(iel,icmp)
  162.  104          continue
  163.             endif
  164.           enddo
  165.  102    continue
  166.  
  167. C       Recuperation du MELVAL dans le materiau
  168.         meleme=imodel.imamod
  169.         conm  =imodel.conmod
  170.         call ident(meleme,conm,ipmatr,0,infos,iret)
  171.         if(iret .eq. 0)then
  172.           CALL ERREUR(21)
  173.           return
  174.         endif
  175.         if(ierr.ne.0) return
  176.  
  177.         nomid=ipnomi
  178.         if    (ICAS .EQ. 1)then
  179.           nomid.lesobl(1)='PRIM'
  180.         elseif(ICAS .EQ. 2)then
  181.           nomid.lesobl(1)='SOLU'
  182.         else
  183.           call erreur(5)
  184.         endif
  185.         call komcha(ipmatr,meleme,conm,ipnomi,notype,1,infos,3,mptval)
  186.         if (ierr.ne.0) return
  187.  
  188.         melva1=mptval.ival(1)
  189.         n1ptel=melva1.velche(/1)
  190.         n1el  =melva1.velche(/2)
  191.  
  192.         do iel=1,meleme.num(/2)
  193.           do ino=1,meleme.num(/1)
  194.             nno          = meleme.num(ino,iel)
  195.             xcpr1(nno,5) = melva1.velche(min(ino,n1ptel),min(iel,n1el))
  196.           enddo
  197.         enddo
  198.  
  199. C       Calcul des jeux
  200.         do 120 ipts=1,nbpts
  201.           ilx1  = nint(xcpr1(ipts,1))
  202.           if(ilx1 .eq. 0)goto 120
  203.  
  204.           xdeb_A        = xcpr1(ipts,3)
  205.           xsol_A        = xcpr1(ipts,5)
  206.           XCPR2(ilx1,1) = 1.D0
  207.           XCPR2(ilx1,2) = xsol_A - xdeb_A
  208.           nbelem        = nbelem + 1
  209.  
  210.           if(ICAS .eq. 2)then
  211.             ilx2          = nint(xcpr1(ipts,2))
  212.             xdeb_B        = xcpr1(ipts,4)
  213.             XCPR2(ilx2,1) = 1.D0
  214.             XCPR2(ilx2,2) =-xdeb_B
  215.             nbelem        = nbelem + 1
  216.           endif
  217.  120    continue
  218.         segsup,mptval
  219.  100  continue
  220.  
  221. *     +-------------------------------------------------------------+
  222. *     |   Creation et Remplissage du CHPOINT de FLX resultat        |
  223. *     +-------------------------------------------------------------+
  224.       nat = 1
  225.       if(nbelem .eq. 0) then
  226.         nbnn   = 0
  227.         nsoupo = 0
  228.         segini,mchpo3
  229.  
  230.       else
  231.         nbnn   = 1
  232.         nbref  = 0
  233.         nbsous = 0
  234.  
  235.         segini,ipt4
  236.         ipt4.itypel = 1
  237.  
  238.         nsoupo = 1
  239.         nc     = 1
  240.         n      = nbelem
  241.         segini,mchpo3,msoup1,mpova1
  242.         mchpo3.ipchp(1)    = msoup1
  243.         msoup1.nocomp(1)   ='FLX'
  244.         msoup1.igeoc       = ipt4
  245.         msoup1.ipoval      = mpova1
  246.  
  247.         ipo=0
  248.         do 301,ia=1,inomax
  249.           itest = nint(XCPR2(ia,1))
  250.           if (itest .eq. 0) goto 301
  251.           ipo                  = ipo + 1
  252.           ipt4.num(1,ipo)      = ia
  253.           mpova1.vpocha(ipo,1) = XCPR2(ia,2)
  254.  301    continue
  255.       endif
  256.  
  257.       mchpo3.mochde    ='chpoint cree par PHAJ'
  258.       mchpo3.mtypoi    ='jeux'
  259.       mchpo3.ifopoi    = ifour
  260.       mchpo3.jattri(1) = 2
  261.  
  262.       nomid=ipnomi
  263.       segsup,notype,nomid
  264.       SEGSUP,XCPR1
  265.  
  266.       call actobj('CHPOINT ',mchpo3,1)
  267.       call ecrobj('CHPOINT ',mchpo3)
  268.  
  269.       RETURN
  270.       END
  271.  
  272.  
  273.  

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