Télécharger phaj.eso

Retour à la liste

Numérotation des lignes :

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

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