Télécharger prdiff.eso

Retour à la liste

Numérotation des lignes :

  1. C PRDIFF SOURCE GOUNAND 16/12/01 21:15:13 9228
  2. C INTERFACE ENTRE LA DIRECTIVE "DIFF" (DIFFERENCE SYMETRIQUE) ET LE
  3. C SOUS PROGRAMME OUEXCL
  4. C
  5. C Modif : 2014 C. BERTHINIER
  6. C Dans le cas de la DIFF de 2 MELEME SIMPLE du meme TYPE, si
  7. C Le résultat est VIDE il est du même type que le MELEME
  8. C SIMPLE donné en argument
  9. C
  10. SUBROUTINE PRDIFF
  11. IMPLICIT INTEGER(I-N)
  12. -INC CCOPTIO
  13. -INC SMELEME
  14. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  15. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  16. IF (IERR.NE.0) RETURN
  17.  
  18. SEGACT IPT1,IPT2
  19.  
  20. IF (IPT1.LISOUS(/1).NE.0) GOTO 10
  21. IF (IPT2.LISOUS(/1).NE.0) GOTO 11
  22.  
  23.  
  24.  
  25. IF ((IPT1.ITYPEL .EQ. IPT2.ITYPEL) .AND.
  26. & (IPT1.NUM(/1) .EQ. IPT2.NUM(/1)) ) THEN
  27. C Cas de deux MAILLAGES SIMPLES, de même TYPE et même NBNN
  28.  
  29. IF (IPT1.EQ.IPT2) THEN
  30. C Les deux maillages sont identiques : résultat vide du même type
  31. ity=ipt1.itypel
  32. call melvid(ity,IPT3)
  33. segact ipt3
  34. ELSE
  35. C OU Exclusif sur IPT1 et IPT2
  36. CALL OUEXCL(IPT1,IPT2,IPT3)
  37.  
  38. IF (IPT3.EQ.0) THEN
  39. C le résultat est vide on lui met le même type
  40. ity=ipt1.itypel
  41. call melvid(ity,IPT3)
  42. segact ipt3
  43. ENDIF
  44. ENDIF
  45. ELSE
  46. C Cas de deux MAILLAGES SIMPLES, de TYPE ou NBNN différent
  47. C Adjonction directe des deux sous-maillages simples de structure différente
  48. C C'est le cas des maillages polyedriques dont NBNN peut varier pour le même ITYPEL
  49. NBELEM =0
  50. NBNN =0
  51. NBREF =0
  52. NBSOUS =2
  53. SEGINI IPT3
  54. IPT3.LISOUS(1)=IPT1
  55. IPT3.LISOUS(2)=IPT2
  56. ENDIF
  57.  
  58. IF (IERR.NE.0) RETURN
  59. GOTO 1000
  60.  
  61.  
  62.  
  63. C Cas d'un MAILLAGE SIMPLE et l'autre COMPLEXE
  64.  
  65. C On intervertit pour que le premier soit le MAILLAGE COMPLEXE
  66. C IPT1 : MELEME COMPLEXE
  67. C IPT2 : MELEME SIMPLE
  68. 10 IF (IPT2.LISOUS(/1).NE.0) GOTO 20
  69. GOTO 12
  70.  
  71. 11 IP=IPT2
  72. IPT2=IPT1
  73. IPT1=IP
  74.  
  75. 12 CONTINUE
  76. DO 13 IS=1,IPT1.LISOUS(/1)
  77. IPT4=IPT1.LISOUS(IS)
  78. SEGACT IPT4
  79. IF (IPT2.NUM(/1).EQ.IPT4.NUM(/1)) THEN
  80. IF (IPT2.ITYPEL.EQ.IPT4.ITYPEL) GOTO 14
  81. ENDIF
  82. SEGDES IPT4
  83. 13 CONTINUE
  84.  
  85. NBELEM=0
  86. NBNN =0
  87. NBREF =0
  88. NBSOU1=IPT1.LISOUS(/1)
  89. NBSOUS=NBSOU1+1
  90. SEGINI IPT3
  91.  
  92. C LES MELEME SIMPLES de IPT1 et IPT2 sont placés dans IPT3
  93. DO 15 IS=1,NBSOU1
  94. IPT3.LISOUS(IS)=IPT1.LISOUS(IS)
  95. 15 CONTINUE
  96.  
  97. IPT3.LISOUS(NBSOUS)=IPT2
  98. GOTO 1000
  99.  
  100. 14 IF (IPT2.EQ.IPT4) GOTO 17
  101.  
  102. CALL OUEXCL(IPT2,IPT4,IPT5)
  103. IF (IERR.NE.0) RETURN
  104. IF (IPT5.EQ.0) GOTO 17
  105. SEGDES IPT4,IPT5
  106.  
  107. NBSOUS=IPT1.LISOUS(/1)
  108. NBNN=0
  109. NBREF=0
  110. NBELEM=0
  111. SEGINI IPT3
  112. DO 16 IS2=1,NBSOUS
  113. IPT3.LISOUS(IS2)=IPT1.LISOUS(IS2)
  114. IF (IS.EQ.IS2) IPT3.LISOUS(IS2)=IPT5
  115. 16 CONTINUE
  116. GOTO 1000
  117.  
  118. 17 SEGDES IPT4
  119.  
  120. C-------- Cas d'un maillage vide ---------------------------------
  121.  
  122. IF (NBSOUS.EQ.0) THEN
  123. CALL melvid(0,ipt3)
  124. segact ipt3
  125. ELSE
  126. NBNN =0
  127. NBREF =0
  128. NBELEM=0
  129. NBSOUS=IPT1.LISOUS(/1)-1
  130. SEGINI IPT3
  131. IS3=0
  132. DO 18 IS2=1,(NBSOUS + 1)
  133. IF (IS2.EQ.IS) GOTO 18
  134. IS3=IS3+1
  135. IPT3.LISOUS(IS3)=IPT1.LISOUS(IS2)
  136. 18 CONTINUE
  137. ENDIF
  138.  
  139. GOTO 1000
  140.  
  141. C---- Les deux maillages entrés sont complexes
  142. 20 CONTINUE
  143. NBSOU1=IPT1.LISOUS(/1)
  144. NBSOU2=IPT2.LISOUS(/1)
  145. NBELEM=0
  146. NBNN =0
  147. NBREF =0
  148. NBSOUS=NBSOU1+NBSOU2
  149. SEGINI IPT4
  150. DO 21 I1=1,NBSOU1
  151. IPT4.LISOUS(I1)=IPT1.LISOUS(I1)
  152. 21 CONTINUE
  153. ISUP=0
  154. DO 22 I2=1,NBSOU2
  155. IPT5=IPT2.LISOUS(I2)
  156. SEGACT IPT5
  157. ITYP=IPT5.ITYPEL
  158. DO 23 I1=1,NBSOU1
  159. IPT6=IPT4.LISOUS(I1)
  160. IF (IPT6.EQ.0) GOTO 23
  161. SEGACT IPT6
  162.  
  163. IF (IPT6.ITYPEL .NE. ITYP) GOTO 24
  164. IF (IPT6.NUM(/1).NE.IPT5.NUM(/1)) GOTO 24
  165. IF (IPT5.EQ.IPT6) GOTO 25
  166.  
  167. CALL OUEXCL(IPT5,IPT6,IPT7)
  168. IF (IERR.NE.0) RETURN
  169. IF (IPT7.EQ.0) GOTO 25
  170. SEGDES IPT5,IPT6
  171. IPT4.LISOUS(I1)=IPT7
  172. IPT4.LISOUS(NBSOU1+I2)=0
  173. ISUP=ISUP+1
  174. GOTO 22
  175.  
  176. 25 ISUP=ISUP+2
  177. IPT4.LISOUS(I1)=0
  178. IPT4.LISOUS(NBSOU1+I2)=0
  179. SEGDES IPT5,IPT6
  180. GOTO 22
  181. 24 SEGDES IPT6
  182. 23 CONTINUE
  183. IPT4.LISOUS(NBSOU1+I2)=IPT5
  184. SEGDES IPT5
  185. 22 CONTINUE
  186.  
  187. IF (ISUP.EQ.0) GOTO 30
  188. NBSOUS=NBSOUS-ISUP
  189.  
  190. C-------- Cas d'un maillage vide ---------------------------------
  191.  
  192. IF (NBSOUS.EQ.0) THEN
  193. call melvid(0,ipt3)
  194. segact ipt3
  195. GOTO 1000
  196. ENDIF
  197.  
  198. SEGINI IPT3
  199. JS=0
  200. DO 35 IS=1,NBSOUS
  201. 36 JS=JS+1
  202. IF (IPT4.LISOUS(JS).EQ.0) GOTO 36
  203. IPT3.LISOUS(IS)=IPT4.LISOUS(JS)
  204. 35 CONTINUE
  205. SEGSUP IPT4
  206. IF (NBSOUS.NE.1) GOTO 1000
  207.  
  208. IPT4=IPT3.LISOUS(1)
  209. SEGSUP IPT3
  210. 30 IPT3=IPT4
  211. SEGACT IPT3
  212.  
  213. 1000 SEGDES IPT1,IPT2
  214.  
  215. C
  216. C Nettoyage du maillage dans le cas ou il contient des sous-parties vides
  217. C
  218. NBSOUS = IPT3.LISOUS(/1)
  219. IF (NBSOUS .NE. 0) THEN
  220. C Cas du maillage résultat ayant plusieurs sous zones
  221. DO 1010 I=1,IPT3.LISOUS(/1)
  222. MELEME = IPT3.LISOUS(I)
  223. SEGACT MELEME
  224.  
  225. IF (NUM(/2) .EQ. 0) THEN
  226. C la sous partie vide est supprimée + tassement du tableau LISOUS
  227. DO 1020 J=I+1,IPT3.LISOUS(/1)
  228. IPT3.LISOUS(J-1)=IPT3.LISOUS(J)
  229. 1020 CONTINUE
  230.  
  231. NBSOUS = NBSOUS - 1
  232. ENDIF
  233. SEGDES MELEME
  234.  
  235. 1010 CONTINUE
  236.  
  237. IF ( NBSOUS .EQ. 0 ) THEN
  238. call melvid(0,ipt3)
  239. ELSEIF ( NBSOUS .EQ. 1 ) THEN
  240. C Passage en MELEME SIMPLE à nouveau
  241. IPT3 = IPT3.LISOUS(1)
  242. SEGACT IPT3
  243. IF(IPT3.NUM(/2) .EQ. 0) THEN
  244. SEGDES IPT3
  245. *sg pas sûr que IPT3 soit neuf ?? SEGSUP IPT3
  246. call melvid(0,ipt3)
  247. ENDIF
  248. ELSEIF ( NBSOUS .NE. IPT3.LISOUS(/1) ) THEN
  249. C Le segment MELEME COMPLEXE est ajusté
  250. NBNN = 0
  251. NBELEM = 0
  252. NBREF = 0
  253. SEGADJ IPT3
  254. ENDIF
  255. ENDIF
  256.  
  257. SEGDES IPT3
  258. CALL ECROBJ('MAILLAGE',IPT3)
  259. RETURN
  260.  
  261. END
  262.  
  263.  
  264.  
  265.  
  266.  

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