Télécharger prdiff.eso

Retour à la liste

Numérotation des lignes :

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

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