Télécharger la plaquette Cast3M


fr en

Télécharger phaj.eso

Retour à la liste

Numérotation des lignes : 

phaj

  1. C PHAJ      SOURCE    CB215821  20/11/25    13:35:42     10792          
  2.       subroutine phaj
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. *
  6. * création des "jeux" a associer aux matrices de blocages pour le
  7. * changement de phase
  8. * en entrée : objet modele , chamelem de temperature de changement
  9. * de phase et temperature initiale, matrice de blocages
  10. *
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMELEME
  15. -INC SMMODEL
  16. -INC SMRIGID
  17. -INC SMCOORD
  18. -INC SMCHPOI
  19. -INC SMCHAML
  20.       segment icpr(nbpts)
  21.       segment icpr1(nbpts)
  22.       segment icpr2(nbpts)
  23.       segment icpr3(nbpts)
  24.       segment  itvr
  25.         real*8  tvr(IB)
  26.       endsegment
  27.       segment ide(ib)
  28.       call LIROBJ('MMODEL  ',mmodel,1,iretou)
  29.       call ACTOBJ('MMODEL  ',mmodel,1)
  30.       if(ierr.ne.0) return
  31.  
  32.       call LIROBJ('MCHAML  ',IPIN,1,iretou)
  33.       call ACTOBJ('MCHAML  ',IPIN,1)
  34.       if(ierr.ne.0) return
  35.  
  36.       CALL REDUAF(IPIN,mmodel,mchelm,0,IR,KER)
  37.       IF(IR   .NE. 1) CALL ERREUR(KER)
  38.       IF(IERR .NE. 0) RETURN
  39.  
  40.       call LIROBJ('CHPOINT ',mchpoi,1,iretou)
  41.       call ACTOBJ('CHPOINT ',mchpoi,1)
  42.       if(ierr.ne.0) return
  43.  
  44.       call LIROBJ('RIGIDITE',mrigid,1,iretou)
  45.       if(ierr.ne.0) return
  46.  
  47.       segact mmodel,mchelm,mrigid
  48. * on recherche la temperature de fusion
  49.       nbsou=kmodel(/1)
  50.       segini icpr,icpr1,icpr2,icpr3
  51. * on compte combien de point aux maximum pour creer un tableau de
  52. * maillage pour le chpoint de FLX et un tableau de valeur mpoval
  53.       ib=0
  54.       do 100 i=1,nbsou
  55.       imodel=kmodel(i)
  56.       segact imodel
  57.       meleme=imamod
  58.       segact meleme
  59.       do 101 mel=1,num(/2)
  60.       do 101 npo=1,num(/1)
  61.       ia = num(npo,mel)
  62.       if(icpr(ia).eq.0) then
  63.       ib=ib+1
  64.       icpr(ia)=ib
  65.       endif
  66.   101 continue
  67.   100 continue
  68. *
  69. * reperage du chpoint de temperature initiales
  70. *
  71.       segact mchpoi
  72.       inon=0
  73.       ive=0
  74.       do 400 nso=1,ipchp(/1)
  75.       msoup1= ipchp(nso)
  76.       segact msoup1
  77.       do 401 nco=1,msoup1.nocomp(/2)
  78.       if(msoup1.nocomp(nco).EQ.'T') go to 402
  79.  401  continue
  80.       inon=inon+1
  81.       go to 400
  82.       moterr(1:4) = 'T   '
  83.       call erreur (181)
  84.       return
  85.  402  continue
  86.       ipt3 = msoup1.igeoc
  87.       segact ipt3
  88.       do 404 nbe=1,ipt3.num(/2)
  89.        ia= ipt3.num(1,nbe)
  90.        ive=ive+1
  91.        icpr1(ia)=ive
  92.        icpr2(ia)=msoup1.ipoval
  93.        icpr3(ia)=nco
  94.   404 continue
  95.        mpova1=msoup1.ipoval
  96.        segact mpova1
  97.   400 continue
  98.       if(inon.eq.ipchp(/1)) then
  99.         moterr(1:4) = 'T   '
  100.         call erreur (181)
  101.         return
  102.       endif
  103. * fin reperage du chpoint
  104.       nbsous=0
  105.       nbref=0
  106.       nbnn=1
  107.       nbelem=ib
  108. *      write(6,*) 'nbelem nbnn nbref nbsous',nbelem,nbnn,nbref,nbsous
  109.       segini ipt4
  110. *      write(6,*)  'sortie de segini'
  111.       n=nbelem
  112.       nc=1
  113.       nat=1
  114.       nsoupo=1
  115.       segini mpoval,msoupo,itvr,ide,mchpo1
  116.       mchpo1.mochde='chpoint créé par sub PHAJ'
  117.       mchpo1.mtypoi='jeux'
  118.       mchpo1.ipchp(1)=msoupo
  119.       mchpo1.jattri(1)=2
  120.        mchpo1.ifopoi=ifour
  121.       igeoc=ipt4
  122.       nocomp(1)='FLX'
  123.       noharm(1)=nifour
  124.       ipoval=mpoval
  125. * boucle sur les sous zones du model pour creer les matrices de
  126. * blocages
  127.       idd=0
  128.       do 1 i=1,nbsou
  129.       imodel=kmodel(i)
  130.       meleme=imamod
  131. * on recherche la temperature de fusion
  132.        do 51 mchm=1,imache(/1)
  133.        if( imache(mchm) . eq. meleme) then
  134.          mchaml=ichaml(mchm)
  135.          go to 52
  136.        endif
  137.    51  continue
  138.        call erreur ( 472)
  139.        return
  140.    52  continue
  141.        segact mchaml
  142.       do 56 n2=1,nomche(/2)
  143.       if( nomche(n2).eq.'TPHA') then
  144.         melval=ielval(n2)
  145.         go to 57
  146.       endif
  147.    56 continue
  148.       moterr(1:8) = 'TPHA'
  149.       call erreur ( 677)
  150.       return
  151.    57 continue
  152.       segact melval
  153.       if(velche(/1)+velche(/2).ne.2) then
  154.         call erreur(922)
  155.         return
  156.       endif
  157.       tt = velche(1,1)
  158. *      write(6,*)'  temperature touvée de changement de phase  ', tt
  159.       ipt2=irigel(1,i)
  160. *      call impp1(meleme,ipt2)
  161. *      call ecmail(ipt2,0)
  162.  
  163.       segact ipt2
  164. * remplissage du chpoint
  165.       do 70 mel=1,ipt2.num(/2)
  166.       iaa = ipt2.num(2,mel)
  167.       icc= icpr(iaa)
  168. *      write(6,*) 'mel  iaa, icc  icpr(1(iaa),icpr(iaa)tt' ,
  169. *     $  iaa, icc,  icpr1(iaa),icpr3(iaa),tt
  170.       if(ide(icc).ne.0) then
  171.         if(tvr(icc).ne.tt) then
  172.            call erreur (921)
  173.            return
  174.         endif
  175.         go to 70
  176.       endif
  177.       ide(icc)=1
  178.       tvr(icc)=tt
  179.       mpova1=icpr2(iaa)
  180. *      write(6,*) ' mpova1 ' , mpova1
  181.       if(mpova1.eq.0) then
  182.          tdec = 0.d0
  183. *         write(6,*) 'phaj: on passe par la si T0 pas defini !'
  184.       else
  185.          tdec = mpova1.vpocha(icpr1(iaa),icpr3(iaa))
  186.       endif
  187.       idd = idd+1
  188.       ipt4.num(1,idd)=ipt2.num(1,mel)
  189.       tjeu= tt-tdec
  190.       if( abs(tjeu) . le . 1.D-4 ) tjeu=0.D0
  191.       vpocha(idd,1)= tjeu
  192. *      write(6,*) ' noeud valeurs ', ipt4.num(1,idd), tt-tdec,tjeu
  193.   70  continue
  194.    1  continue
  195.       segdes mrigid
  196.       nbnn=1
  197.       nbelem=idd
  198.       n=idd
  199.       nc=1
  200.       segadj ipt4
  201.       segadj mpoval
  202.       segsup icpr,itvr,ide,icpr1,icpr2,icpr3
  203.       do 410 k=1,ipchp(/1)
  204.         msoupo=ipchp(k)
  205.         meleme=igeoc
  206.        mpoval=ipoval
  207.   410 continue
  208.  
  209.       call ACTOBJ('CHPOINT',mchpo1,1)
  210.       call ECROBJ('CHPOINT',mchpo1)
  211.  
  212.       end
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  

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