Télécharger prsurf.eso

Retour à la liste

Numérotation des lignes :

  1. C PRSURF SOURCE BP208322 16/11/18 21:20:21 9177
  2. C CE SOUS PROGRAMME SERT D'INTERFACE POUR LE SOUS PROGRAMME TRANSF
  3. C IL PREPARE SES DONNEES ET PROJETTE LES POINTS SUR UN PLAN
  4. C
  5. SUBROUTINE PRSURF
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. -INC SMELEME
  9. -INC CCOPTIO
  10. -INC CCGEOME
  11. -INC SMCOORD
  12. real*8 tcval(13)
  13. SEGMENT XPROJ(3,1)
  14. SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR)
  15. SEGMENT/SAUV/(NSA(MAI(ITOUR+1)))
  16. PARAMETER (LCAS = 6)
  17. DIMENSION ITEST(0:30)
  18. CHARACTER*4 MCLE(6)
  19. DATA MCLE/'PLAN','SPHE','CYLI','CONI','TORI','POLY'/
  20. isens=0
  21. msurfp=0
  22. DO 2 I=0,NBCOUL-1
  23. 2 ITEST(I)=0
  24. IOBL=IDIM-2
  25. NBCAS=6
  26. IF (IDIM.EQ.2) NBCAS=1
  27. CALL MESLIR(-230)
  28. ICOND=1
  29. IF (IDIM.EQ.2) ICOND=0
  30. CALL LIRMOT(MCLE,NBCAS,ICAS,ICOND)
  31. IF (IERR.GT.1) RETURN
  32. IF (IDIM.EQ.2) ICAS=1
  33. IF (ICAS .EQ. 6) THEN
  34. CALL SURFP1 ('SURF',IBID,IBID,IBID,IBID,IPT1,msurfp)
  35. ELSE
  36. CALL MESLIR(-229)
  37. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  38. CALL MESLIR(-228)
  39. IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU)
  40. CALL MESLIR(-227)
  41. IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU)
  42. CALL MESLIR(-226)
  43. IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU)
  44. END IF
  45. IF (IERR.NE.0) RETURN
  46. IPCON=IPT1
  47. SEGACT IPT1
  48. IF (KSURF(IPT1.ITYPEL).NE.0) CALL ERREUR(16)
  49. IF (IERR.GT.1) RETURN
  50. IPT5=1
  51. CALL AVTRSF(IPT1,FER,IPT5)
  52. IF (IERR.GT.1) RETURN
  53. DO 12 I=1,IPT1.NUM(/2)
  54. ITEST(IPT1.ICOLOR(I))=1
  55. 12 CONTINUE
  56. ICHCOL=-1
  57. DO 14 I=0,NBCOUL-1
  58. IF (ITEST(I).EQ.1) THEN
  59. IF (ICHCOL.EQ.-1) THEN
  60. ICHCOL=I
  61. ELSE
  62. ICHCOL=ITABM(ICHCOL,I)
  63. ENDIF
  64. ENDIF
  65. 14 CONTINUE
  66. SEGDES IPT1
  67. SEGINI SAUV
  68. DO 60 I=1,NSA(/1)
  69. 60 NSA(I)=NFI(I)
  70. ichp=0
  71. * Lecture chpoin de densite
  72. call lirobj('CHPOINT',ichp,0,iretou)
  73. if (ichp.ne.0) call menfor(ichp,fer)
  74. IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ ,NDEB,NUMNP,tcval)
  75. IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ ,NDEB,NUMNP,IP1,tcval)
  76. IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  77. $ tcval,isens)
  78. IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  79. $ tcval,isens)
  80. IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  81. $ isens)
  82. IF(ICAS.EQ.6)CALL SURFP5 (FER,XPROJ,NDEB,msurfp)
  83. IF (IERR.GT.1) RETURN
  84. if (ichp.ne.0) call menfo2(ichp,fer,xproj)
  85. DO 84, NUCOT = 1, ITOUR
  86. *
  87. IDEB = MAI(NUCOT)
  88. IFIN = MAI(NUCOT+1)-1
  89. *
  90. DO 84, IP2 = IDEB, IFIN
  91. *
  92. *
  93. 84 CONTINUE
  94.  
  95.  
  96. * cas du maillage polygonal ==> dualisation
  97. if (ILCOUR.eq.32) call dualis(fer,ifer,xproj,iproj)
  98. CALL PRAJUS(FER,XPROJ,IPT2,NUMELG,NUMNP,ichp)
  99. IF (IERR.GT.1) RETURN
  100. IF (ICAS .EQ. 6) THEN
  101. ID1=XCOOR(/1)/(IDIM+1)
  102. CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,0,msurfp)
  103. CALL AMELI1 (IPT2,SAUV,ID1,NDEB,NUMNP,NUMELG)
  104. NDEB = NUMNP + 1
  105. END IF
  106. *
  107. * Cas du maillage polygonal ==> dualisation
  108. *
  109. IF (ILCOUR.eq.32) THEN
  110. call duali2(ifer,xproj,iproj,ipt2,numelg,ndeb,numnp)
  111. ELSE
  112. IPT2.ITYPEL=4
  113. IF (KSURF(ILCOUR).GE.8) IPT2.ITYPEL=8
  114. ITY=IPT2.ITYPEL
  115. IF (KSURF(ILCOUR).EQ.6.OR.KSURF(ILCOUR).EQ.10) ITY=ITY+2
  116. CALL CHANGS(NUMNP,NUMELG,ITY,IPT2,XPROJ,IPT5)
  117. ENDIF
  118. ID1=XCOOR(/1)/(IDIM+1)
  119. IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ ,NDEB,NUMNP,tcval)
  120. IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ ,NDEB,NUMNP,IP1,tcval)
  121. IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  122. $ tcval,isens)
  123. IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  124. $ tcval,isens)
  125. IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  126. $ isens)
  127. IF(ICAS.EQ.6)CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,1,msurfp)
  128. IF (KSURF(ILCOUR).GE.8) GOTO 100
  129. NBNN=IPT2.NUM(/1)
  130. NBREF=1
  131. NBSOUS=0
  132. NBELEM=NUMELG
  133. SEGINI IPT1
  134. IDEC=ID1-NDEB+1
  135. DO 50 J=1,NBELEM
  136. IPT1.ICOLOR(J)=ICHCOL
  137. DO 50 I=1,NBNN
  138. IANC=IPT2.NUM(I,J)
  139. IF (IANC.GE.NDEB) GOTO 61
  140. IPT1.NUM(I,J)=NSA(IANC)
  141. GOTO 50
  142. 61 IPT1.NUM(I,J)=IANC+IDEC
  143. 50 CONTINUE
  144. SEGSUP SAUV
  145. IPT1.ITYPEL=IPT2.ITYPEL
  146. SEGSUP IPT2
  147. 200 CONTINUE
  148. * IPT5=IPCON PARAIT INUTILE PV |
  149. * SEGINI ,IPT6=IPT5
  150. * DO 210 I=1,IPT6.NUM(/2)
  151. *210 IPT6.ICOLOR(I)=ICHCOL
  152. * IPT1.LISREF(1)=IPT6
  153. IPT1.LISREF(1)=IPCON
  154. CALL ECROBJ('MAILLAGE',IPT1)
  155. SEGDES IPT1
  156. RETURN
  157. 100 CONTINUE
  158. *
  159. IF (ILCOUR .EQ. 32) THEN
  160. *
  161. * Polygone
  162. *
  163. IPT1 = IPT2
  164. NBSOUS=IPT1.LISOUS(/1)
  165. IDEC=ID1-NDEB+1
  166. NBELEM=0
  167. NBNN=0
  168. NBREF=1
  169. SEGADJ IPT1
  170. IPT1.LISREF(1)= IPCON
  171. DO 80, NTEL = 1, IPT1.LISOUS(/1)
  172. IPT3 = IPT1.LISOUS(NTEL)
  173. NBELEM = IPT3.NUM(/2)
  174. DO 80, NBEL = 1, NBELEM
  175. IPT3.ICOLOR(NBEL) = ICHCOL
  176. DO 80, NUN = 1, IPT3.NUM(/1)
  177. IANC=IPT3.NUM(NUN,NBEL)
  178. IF (IANC .GE.NDEB) THEN
  179. IPT3.NUM(NUN,NBEL)=IANC+IDEC
  180. ELSE
  181. IPT3.NUM(NUN,NBEL)=NSA(IANC)
  182. ENDIF
  183. 80 CONTINUE
  184. CALL ECROBJ('MAILLAGE',IPT1)
  185. DO 85, NTEL = 1, IPT1.LISOUS(/1)
  186. IPT3 = IPT1.LISOUS(NTEL)
  187. SEGDES IPT3
  188. 85 CONTINUE
  189. SEGDES IPT1
  190. RETURN
  191. *
  192. ENDIF
  193. C ON A DES CARRES ET DES TRIANGLES
  194. NBRE=IPT2.NUM(/1)
  195. IDEC=ID1-NDEB+1
  196. NBSOUS=0
  197. NBREF=0
  198. NBTRI=0
  199. DO 101 I=1,NUMELG
  200. IF (IPT2.NUM(NBRE,I).NE.0) GOTO 101
  201. NBTRI=NBTRI+1
  202. 101 CONTINUE
  203. NBELEM=NBTRI
  204. IF (NBTRI.EQ.NUMELG) NBREF=1
  205. NBNN=3
  206. IF (NBTRI.EQ.0) GOTO 104
  207. IF (NBRE.EQ.8) NBNN=6
  208. NBNNT=NBNN
  209. SEGINI IPT3
  210. C A CAUSE DE L'OPTIMISEUR IBM (POUR AVOIR IPT4<>0)
  211. IPT4=IPT3
  212. IPT3.ITYPEL=4
  213. IF (NBRE.EQ.8) IPT3.ITYPEL=6
  214. 104 CONTINUE
  215. NBNN=NBRE
  216. NBNNQ=NBNN
  217. NBELEM=NUMELG-NBTRI
  218. IF (NBELEM.EQ.0) GOTO 105
  219. IF (NBELEM.EQ.NUMELG) NBREF=1
  220. SEGINI IPT4
  221. C TOUJOURS L'OPTIMISEUR
  222. IF (NBTRI.EQ.0) IPT3=IPT4
  223. IPT4.ITYPEL=8
  224. IF (NBRE.EQ.8) IPT4.ITYPEL=10
  225. 105 CONTINUE
  226. J=0
  227. K=0
  228. DO 102 I=1,NUMELG
  229. IF (IPT2.NUM(NBRE,I).NE.0) GOTO 103
  230. J=J+1
  231. IPT3.ICOLOR(J)=ICHCOL
  232. DO 110 L=1,NBNNT
  233. IANC=IPT2.NUM(L,I)
  234. IF (IANC.GE.NDEB) GOTO 111
  235. IPT3.NUM(L,J)=NSA(IANC)
  236. GOTO 110
  237. 111 IPT3.NUM(L,J)=IANC+IDEC
  238. 110 CONTINUE
  239. GOTO 102
  240. 103 K=K+1
  241. IPT4.ICOLOR(K)=ICHCOL
  242. DO 120 L=1,NBNNQ
  243. IANC=IPT2.NUM(L,I)
  244. IF (IANC.GE.NDEB) GOTO 121
  245. IPT4.NUM(L,K)=NSA(IANC)
  246. GOTO 120
  247. 121 IPT4.NUM(L,K)=IANC+IDEC
  248. 120 CONTINUE
  249. 102 CONTINUE
  250. SEGSUP IPT2,SAUV
  251. IF (NBTRI.NE.0) SEGDES IPT3
  252. IF (NBELEM.NE.0) SEGDES IPT4
  253. NBNN=0
  254. NBQUA=NBELEM
  255. NBELEM=0
  256. NBSOUS=0
  257. IF (NBTRI.NE.0) NBSOUS=NBSOUS+1
  258. IF (NBQUA.NE.0) NBSOUS=NBSOUS+1
  259. IF (NBSOUS.EQ.1) GOTO 180
  260. NBREF=1
  261. SEGINI IPT1
  262. ISOUS=0
  263. IF (NBTRI.EQ.0) GOTO 171
  264. ISOUS=ISOUS+1
  265. IPT1.LISOUS(ISOUS)=IPT3
  266. 171 CONTINUE
  267. IF (NBQUA.EQ.0) GOTO 172
  268. ISOUS=ISOUS+1
  269. IPT1.LISOUS(ISOUS)=IPT4
  270. 172 CONTINUE
  271. GOTO 200
  272. 180 CONTINUE
  273. IF (NBTRI.NE.0) IPT1=IPT3
  274. IF (NBQUA.NE.0) IPT1=IPT4
  275. SEGACT IPT1*MOD
  276. IPT1.LISREF(1)=IPCON
  277. GOTO 200
  278. END
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  

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