Télécharger jeupha.eso

Retour à la liste

Numérotation des lignes :

jeupha
  1. C JEUPHA SOURCE CB215821 21/08/20 21:15:12 11089
  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.  

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