Télécharger demete.eso

Retour à la liste

Numérotation des lignes :

  1. C DEMETE SOURCE JC220346 16/11/29 21:15:10 9221
  2. C|-------------------------------------------------------------------|
  3. C| |
  4. C| INTERFACE ENTRE VOLUME ET DEMAIT |
  5. C| ALLOUE LES TABLEAUX ET LES INITIALISE |
  6. C| |
  7. C|-------------------------------------------------------------------|
  8. C
  9. SUBROUTINE DEMETE(MELEME)
  10. C
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8(A-H,O-Z)
  13. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  14. SEGMENT IDCP(NPTINI)
  15. -INC SMCOORD
  16. -INC CCOPTIO
  17. -INC CCGEOME
  18. -INC SMELEME
  19. -INC TDEMAIT
  20. DATA IPREM/0/
  21. IF (IDIM.NE.3) CALL ERREUR(16)
  22. IF (IERR.NE.0) RETURN
  23. MELSUR=MELEME
  24. IPT8=MELEME
  25. SEGACT MELEME
  26. NBELEM=NUM(/2)
  27. NBSOUS=LISOUS(/1)
  28. IF (NBSOUS.EQ.0) GOTO 100
  29. DO 10 IOB=1,NBSOUS
  30. IPT1=LISOUS(IOB)
  31. SEGACT IPT1
  32. NBELEM=NBELEM+IPT1.NUM(/2)
  33. 10 CONTINUE
  34. 100 CONTINUE
  35. * LES DIMENSIONS SERONT AJUSTEES EN FONCTION DES BESOINS DANS DEMAIT
  36. NFTOT=NBELEM+100
  37. SEGINI NFC
  38. SEGINI NFV
  39. SEGACT MCOORD
  40. SEGINI ICPR
  41. C* DO 200 I=1,XCOOR(/1)/(IDIM+1)
  42. C* ICPR(I)=0
  43. C* 200 CONTINUE
  44. IK=0
  45. IELBAS=0
  46. IPT1=MELEME
  47. IDEGR=0
  48. DO 220 IOB=1,MAX(1,LISOUS(/1))
  49. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB)
  50. L=IPT1.NUM(/1)
  51. IF (IDEGR.EQ.0) THEN
  52. IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) IDEGR=1
  53. IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) IDEGR=2
  54. ELSEIF (IDEGR.EQ.1) THEN
  55. IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) CALL ERREUR(16)
  56. ELSEIF (IDEGR.EQ.2) THEN
  57. IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) CALL ERREUR(16)
  58. ENDIF
  59. IF (IDEGR.EQ.0) CALL ERREUR(16)
  60. IF (IERR.NE.0) GOTO 1000
  61. DO 230 INB=1,L,IDEGR
  62. DO 230 IEL=1,IPT1.NUM(/2)
  63. IP=IPT1.NUM(INB,IEL)
  64. IF (ICPR(IP).NE.0) GOTO 240
  65. IK=IK+1
  66. ICPR(IP)=IK
  67. 240 CONTINUE
  68. NFC((INB-1)/IDEGR+1,IEL+IELBAS)=ICPR(IP)
  69. 230 CONTINUE
  70. IF (L.EQ.4.OR.L.EQ.8) GOTO 260
  71. DO 250 IEL=1,IPT1.NUM(/2)
  72. NFC(4,IEL+IELBAS)=0
  73. 250 CONTINUE
  74. 260 CONTINUE
  75. IELBAS=IELBAS+IPT1.NUM(/2)
  76. IF (LISOUS(/1).NE.0) SEGDES IPT1
  77. 220 CONTINUE
  78. NVTOT=50
  79. NPTOT=IK+50
  80. SEGINI NPF,IFUT,XYZ,IVOL,IFAT
  81. SEGDES MELEME
  82. NFCMAX=IELBAS
  83. NFACET=NFCMAX
  84. NVOL=0
  85. NPTMAX=IK
  86. NPTINI=NPTMAX
  87. SEGINI IDCP
  88. DO 500 I=1,XCOOR(/1)/(IDIM+1)
  89. if (icpr(i).ne.0) IDCP(ICPR(I))=I
  90. 500 CONTINUE
  91. C REMPLIR IFUT
  92. DO 400 I=1,NFACET
  93. IFUT(I)=I
  94. 400 CONTINUE
  95. DO 300 IP=1,XCOOR(/1)/(IDIM+1)
  96. IPL=ICPR(IP)
  97. IF (IPL.EQ.0) GOTO 300
  98. IREF=4*(IP-1)
  99. DO 310 IC=1,3
  100. XYZ(IC,IPL)=XCOOR(IREF+IC)
  101. 310 CONTINUE
  102. 300 CONTINUE
  103. SEGSUP ICPR
  104. IF (IPREM.EQ.0.AND.IVERB.EQ.1) WRITE (IOIMP,*)
  105. # ' DEMETE VERSION 2.0.beta (C) CEA/SEMT - P VERPEAUX '
  106. IPREM=1
  107. * WRITE (IOIMP,2000) NFCMAX,NFACET,NVOL,NPTMAX
  108. *2000 FORMAT (' DEMETE NFCMAX ',I5,' NFACET ',I5,' NVOL ',I5,
  109. * # ' NPTMAX ',I5)
  110. NPTBAS=XCOOR(/1)/(IDIM+1)
  111. IF (IVERB.EQ.1) WRITE(IOIMP,*) ' nptbas,nptini ',nptbas,nptini
  112. CALL DEMAIT(idcp,nptbas)
  113. IF (IERR.NE.0) GOTO 1100
  114. IF (NVOL.EQ.0) GOTO 1100
  115. IF (IVERB.EQ.1) WRITE (IOIMP,*) ' DEMETE MISSION ACCOMPLIE '
  116. * WRITE (IOIMP,9702) NPTBAS,NPTINI,NPTMAX
  117. *9702 FORMAT(' DEMETE NPTBAS ',I5,' NPTINI ',I5,' NPTMAX ',I5)
  118. IF (NPTINI.EQ.NPTMAX) GOTO 5001
  119. NBPTA=XCOOR(/1)/4
  120. NBPTS=NBPTA+NPTMAX-NPTINI
  121. SEGADJ MCOORD
  122. DO 5000 I=NPTINI+1,NPTMAX
  123. DO 5010 J=1,4
  124. XCOOR(NBPTA*4+J)=XYZ(J,I)
  125. 5010 CONTINUE
  126. NBPTA=NBPTA+1
  127. 5000 CONTINUE
  128. 5001 CONTINUE
  129. NHE=0
  130. NPR=0
  131. NPY=0
  132. NTE=0
  133. DO 5800 I=1,NVOL
  134. IF (IVOL(9,I).NE.20) GOTO 5805
  135. NHE=NHE+1
  136. GOTO 5800
  137. 5805 IF (IVOL(9,I).NE.30) GOTO 5810
  138. NPR=NPR+1
  139. GOTO 5800
  140. 5810 IF (IVOL(9,I).NE.35) GOTO 5815
  141. NPY=NPY+1
  142. GOTO 5800
  143. 5815 IF (IVOL(9,I).NE.25) GOTO 5800
  144. NTE=NTE+1
  145. 5800 CONTINUE
  146. IF (IVERB.EQ.1) WRITE (IOIMP,50002) NHE,NPR,NPY,NTE
  147. 50002 FORMAT(' HEXAEDRES PRISMES PYRAMIDES TETRAEDRES ',4I6)
  148. C POUR EVITER LES ENNUIS AVEC L'OPTIMISEUR
  149. IPT1=IVOL
  150. IPT2=IVOL
  151. IPT3=IVOL
  152. IPT4=IVOL
  153. IPT5=IVOL
  154. NBS=0
  155. NBSOUS=0
  156. NBREF=0
  157. IF (NHE.EQ.0) GOTO 5900
  158. NBNN=8
  159. NBELEM=NHE
  160. SEGINI IPT1
  161. IPT5=IPT1
  162. IPT1.ITYPEL=14
  163. NBS=NBS+1
  164. 5900 IF (NPR.EQ.0) GOTO 5901
  165. NBNN=6
  166. NBELEM=NPR
  167. SEGINI IPT2
  168. IPT5=IPT2
  169. IPT2.ITYPEL=16
  170. NBS=NBS+1
  171. 5901 IF (NPY.EQ.0) GOTO 5902
  172. NBNN=5
  173. NBELEM=NPY
  174. SEGINI IPT3
  175. IPT5=IPT3
  176. IPT3.ITYPEL=25
  177. NBS=NBS+1
  178. 5902 IF (NTE.EQ.0) GOTO 5903
  179. NBNN=4
  180. NBELEM=NTE
  181. SEGINI IPT4
  182. IPT5=IPT4
  183. IPT4.ITYPEL=23
  184. NBS=NBS+1
  185. 5903 CONTINUE
  186. NHE=0
  187. NPR=0
  188. NPY=0
  189. NTE=0
  190. DO 6000 I=1,NVOL
  191. IF (IVOL(9,I).NE.20) GOTO 6010
  192. NHE=NHE+1
  193. IPT1.ICOLOR(NHE)=IDCOUL
  194. DO 6001 J=1,8
  195. IP=IVOL(J,I)
  196. IF (IP.LE.NPTINI) THEN
  197. IPT1.NUM(J,NHE)=IDCP(IP)
  198. ELSE
  199. IPT1.NUM(J,NHE)=IP-NPTINI+NPTBAS
  200. ENDIF
  201. 6001 CONTINUE
  202. GOTO 6000
  203. 6010 IF (IVOL(9,I).NE.30) GOTO 6020
  204. NPR=NPR+1
  205. IPT2.ICOLOR(NPR)=IDCOUL
  206. DO 6011 J=1,6
  207. IP=IVOL(J,I)
  208. IF (IP.LE.NPTINI) THEN
  209. IPT2.NUM(J,NPR)=IDCP(IP)
  210. ELSE
  211. IPT2.NUM(J,NPR)=IP-NPTINI+NPTBAS
  212. ENDIF
  213. 6011 CONTINUE
  214. GOTO 6000
  215. 6020 IF (IVOL(9,I).NE.35) GOTO 6030
  216. NPY=NPY+1
  217. IPT3.ICOLOR(NPY)=IDCOUL
  218. DO 6021 J=1,5
  219. IP=IVOL(J,I)
  220. IF (IP.LE.NPTINI) THEN
  221. IPT3.NUM(J,NPY)=IDCP(IP)
  222. ELSE
  223. IPT3.NUM(J,NPY)=IP-NPTINI+NPTBAS
  224. ENDIF
  225. 6021 CONTINUE
  226. GOTO 6000
  227. 6030 IF (IVOL(9,I).NE.25) GOTO 6000
  228. NTE=NTE+1
  229. IPT4.ICOLOR(NTE)=IDCOUL
  230. DO 6031 J=1,4
  231. IP=IVOL(J,I)
  232. IF (IP.LE.NPTINI) THEN
  233. IPT4.NUM(J,NTE)=IDCP(IP)
  234. ELSE
  235. IPT4.NUM(J,NTE)=IP-NPTINI+NPTBAS
  236. ENDIF
  237. 6031 CONTINUE
  238. 6000 CONTINUE
  239. IF (NBS.EQ.1) GOTO 6200
  240. NBREF=1
  241. NBELEM=0
  242. NBNN=0
  243. NBSOUS=NBS
  244. SEGINI MELEME
  245. LISREF(1)=IPT8
  246. NBS=0
  247. IF (NHE.EQ.0) GOTO 6100
  248. NBS=NBS+1
  249. LISOUS(NBS)=IPT1
  250. NBNN=IPT1.NUM(/1)
  251. NBELEM=IPT1.NUM(/2)
  252. SEGDES IPT1
  253. 6100 IF (NPR.EQ.0) GOTO 6101
  254. NBS=NBS+1
  255. LISOUS(NBS)=IPT2
  256. SEGDES IPT2
  257. 6101 IF (NPY.EQ.0) GOTO 6102
  258. NBS=NBS+1
  259. LISOUS(NBS)=IPT3
  260. SEGDES IPT3
  261. 6102 IF (NTE.EQ.0) GOTO 6103
  262. NBS=NBS+1
  263. LISOUS(NBS)=IPT4
  264. SEGDES IPT4
  265. 6103 CONTINUE
  266. SEGDES MELEME
  267. GOTO 1100
  268. 1100 SEGSUP IDCP
  269. GOTO 1020
  270. 6200 CONTINUE
  271. NBREF=1
  272. NBSOUS=0
  273. NBNN=IPT5.NUM(/1)
  274. NBELEM=IPT5.NUM(/2)
  275. SEGINI MELEME
  276. LISREF(1)=IPT8
  277. ITYPEL=IPT5.ITYPEL
  278. DO 6210 J=1,NBELEM
  279. ICOLOR(J)=IPT5.ICOLOR(J)
  280. DO 6210 I=1,NBNN
  281. NUM(I,J)=IPT5.NUM(I,J)
  282. 6210 CONTINUE
  283. SEGSUP IPT5
  284. SEGDES MELEME
  285. GOTO 1100
  286. 1000 SEGSUP ICPR
  287. 1020 SEGSUP NFC,NFV,NPF,IFUT,XYZ,IVOL,ICPR,IFAT
  288. IF (IDEGR.EQ.2) CALL DEMCHA(MELSUR,MELEME)
  289. RETURN
  290. END
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  

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