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

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