Télécharger psiphi.eso

Retour à la liste

Numérotation des lignes :

  1. C PSIPHI SOURCE PV 20/04/16 21:15:01 10584
  2. SUBROUTINE PSIPHI
  3. ***********************************************************************
  4. c OPERATEUR : PSIP
  5. c
  6. c APPEL :
  7. c CHP1 (CHP2) (CHP3) = PSIP MAIL1 MAIL2 (CRIT1) (|'DEUX' | | P1 (P2) | );
  8. c |'TROI' | | MAIL3 |
  9. c
  10. c FONCTION : calcule les fonctions distances signées (level set)
  11. c relatives aux maillages MAIL2 (surface de fissure)
  12. c et MAIL3 en 3D (front de fissure)
  13. c ou P1 en 2D (pointe de fissure)
  14. c aux noeuds de MAIL1 (pas trop éloignés).
  15. c
  16. c CREATION : chat (16/07/2007)
  17. c MODIFS : bp (2009 -> 2012) : diverses corrections/ameliorations
  18. c repertoriees par les fiches d'anomalies/developpement
  19. c bp 14/03/2012 : on split psiphi en psiphi psip2d psip3d et
  20. c zonag2 (evolué seulement le 18/12/2013)
  21. c
  22. c TO DO : cas 3d avec plusieurs fronts (ou 1 front discontinu)
  23. c
  24. ***********************************************************************
  25. IMPLICIT REAL*8(A-H,O-Z)
  26. IMPLICIT INTEGER(I-N)
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC SMCOORD
  31. -INC SMELEME
  32. -INC SMCHPOI
  33. -INC CCREEL
  34. PARAMETER(NMOCLE=2)
  35. CHARACTER*4 MOCLE(NMOCLE)
  36. DATA MOCLE/'DEUX','TROI'/
  37.  
  38. if(iimpi.ge.1) write(ioimp,*)'==== ENTREE DANS PSIPHI ====='
  39. segact mcoord
  40.  
  41. ***********************************************************************
  42. * INITIALISATIONs et LECTUREs
  43. ***********************************************************************
  44. *
  45. * calcule t'on phi? phi ET psi? phi, psi et tau?
  46. ideux=0
  47. call lirmot (mocle,nmocle,ideux,0)
  48. if (ideux.eq.2.and.idim.lt.3) then
  49. write(*,*) ' ON NE PEUT CALCULER TROIS LEVEL SET QU EN 3D !'
  50. write(*,*) ' ON CONTINUE AVEC LE CALCUL DE 2 LEVEL SET ...'
  51. ideux=1
  52. endif
  53.  
  54. * lecture des points pour lesquels on veut calculer phi et psi
  55. call LIROBJ('MAILLAGE',ipt1,1,iretou)
  56. melmai=ipt1
  57. if(ierr.ne.0) return
  58. call change(ipt1,1)
  59. c segact ipt1
  60. c rem: inutile car change laisse ipt1 actif
  61.  
  62. * lecture du maillage de la fissure
  63. call LIROBJ('MAILLAGE',meleme,1,iretou)
  64. melfis=meleme
  65. if(ierr.ne.0) return
  66.  
  67. * lecture de la pointe de fissure (objet de type point) ou du front
  68. ip1=0
  69. ip2=0
  70. melfro=0
  71. 1 continue
  72. if (ideux.ge.1) then
  73. if (idim.eq.2) then
  74. call LIROBJ('POINT',ipt,0,iretou)
  75. if (iretou.ne.0) then
  76. if (ip1.eq.0) then
  77. ip1 = ipt
  78. go to 1
  79. else
  80. ip2 = ipt
  81. endif
  82. endif
  83. else
  84. call LIROBJ('MAILLAGE', melfro ,1,iretou)
  85. if(iretou.eq.0) write(ioimp,*) 'Il manque le maillage du front'
  86. if(IERR.NE.0) return
  87. endif
  88. endif
  89.  
  90. * lecture facultative d'une longueur max (=plus grande taille des elements
  91. * concernés par la fissure)
  92. xcrit=0.D0
  93. call lirree(xcrit,0,ircrit)
  94.  
  95.  
  96.  
  97. ***********************************************************************
  98. * CRÉATION DES MCHPOI DE SORTIE (1 POUR PSI , 2 POUR PHI, 3 POUR TAU)
  99. ***********************************************************************
  100. mpova1=0
  101. mpova2=0
  102. mpova3=0
  103.  
  104. *-----PHI-----
  105. c if(idebug.eq.1) write(6,*) '----Creation de PHI----'
  106. nat=1
  107. nsoupo=1
  108. nc=1
  109. n=ipt1.num(/2)
  110. segini,mchpo2
  111. segini,msoup2
  112. mchpo2.jattri(1)=1
  113. mchpo2.ipchp(1)=msoup2
  114. mchpo2.ifopoi=ifour
  115. segdes mchpo2
  116. msoup2.igeoc=ipt1
  117. msoup2.nocomp(1)='PHI'
  118. msoup2.noharm(1)=nifour
  119. segini,mpova2
  120. msoup2.ipoval=mpova2
  121. c segdes,msoup2
  122.  
  123. *-----PSI-----
  124. if (ideux.ge.1) then
  125. c if(idebug.eq.1) write(6,*) '----Creation de PSI----'
  126. segini,mchpo1
  127. segini,msoup1
  128. mchpo1.jattri(1)=1
  129. mchpo1.ipchp(1)=msoup1
  130. mchpo1.ifopoi=ifour
  131. segdes,mchpo1
  132. msoup1.igeoc=ipt1
  133. msoup1.nocomp(1)='PSI'
  134. msoup1.noharm(1)=nifour
  135. segini,mpova1
  136. msoup1.ipoval=mpova1
  137. c segdes,msoup1
  138. else
  139. msoup1 = 0
  140. endif
  141.  
  142. *-----TAU-----
  143. if (ideux.ge.2) then
  144. c if(idebug.eq.1) write(6,*) '----Creation de TAU----'
  145. segini,mchpo3
  146. segini,msoup3
  147. mchpo3.jattri(1)=1
  148. mchpo3.ipchp(1)=msoup3
  149. mchpo3.ifopoi=ifour
  150. segdes,mchpo3
  151. msoup3.igeoc=ipt1
  152. msoup3.nocomp(1)='TAU'
  153. msoup3.noharm(1)=nifour
  154. segini,mpova3
  155. msoup3.ipoval=mpova3
  156. c segdes,msoup3
  157. else
  158. msoup3 = 0
  159. endif
  160.  
  161.  
  162. ***********************************************************************
  163. * PSIPHI 3D/2D
  164. ***********************************************************************
  165. if (idim.eq.3) then
  166. c write(ioimp,*)'appel PSIP3D (',ideux,ipt1,melfis,melfro,xcrit
  167. call PSIP3D(ideux,ipt1,melfis,melfro,xcrit,
  168. & msoup1,msoup2,msoup3)
  169. else
  170. c write(ioimp,*)'appel PSIP3D (',ideux,ipt1,melfis,ip1,ip2,xcrit
  171. call PSIP2D(ideux,ipt1,melfis,ip1,ip2,xcrit,
  172. & msoup1,msoup2)
  173. endif
  174.  
  175.  
  176. ***********************************************************************
  177. * ECRITURE ET FIN DU PROGRAMME
  178. ***********************************************************************
  179.  
  180. c-----ecriture de (PSI) PHI ((TAU)) --------------
  181. if(ideux.ge.2) then
  182. call ACTOBJ('CHPOINT ',mchpo3,1)
  183. call ECROBJ('CHPOINT ',mchpo3)
  184. endif
  185. call ACTOBJ('CHPOINT ',mchpo2,1)
  186. call ECROBJ('CHPOINT ',mchpo2)
  187. if(ideux.ge.1) then
  188. call ACTOBJ('CHPOINT',mchpo1,1)
  189. call ECROBJ('CHPOINT',mchpo1)
  190. endif
  191.  
  192. end
  193.  
  194.  
  195.  
  196.  

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