Télécharger j3fac0.eso

Retour à la liste

Numérotation des lignes :

  1. C J3FAC0 SOURCE CB215821 18/09/13 21:15:40 9917
  2. SUBROUTINE J3FAC0
  3. C----------------------------------------------------
  4. C TEST POUR LES FACES
  5. C PP 6/97
  6. C Pierre Pegon/JRC Ispra
  7. C----------------------------------------------------
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMTABLE
  14. -INC SMELEME
  15. -INC SMCOORD
  16. -INC CCGEOME
  17. -INC CCNOYAU
  18. -INC CCASSIS
  19. C
  20. SEGMENT BLOCOM
  21. INTEGER POINT(NPOINT)
  22. REAL*8 YCOOR(IDIM+1,NPOINT)
  23. INTEGER MAILL(MM1)
  24. ENDSEGMENT
  25. POINTEUR BLOCO1.BLOCOM
  26. C
  27. SEGMENT VWORK
  28. INTEGER FWWORK(NFACE)
  29. ENDSEGMENT
  30. SEGMENT VWORK1.VWORK
  31. C
  32. SEGMENT WWORK
  33. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  34. INTEGER FWORK
  35. INTEGER TWORK(NTROU)
  36. ENDSEGMENT
  37. C
  38. SEGMENT WORK
  39. REAL*8 XYC(2,NPTO)
  40. INTEGER IST(3,NPTO)
  41. REAL*8 DENS(NPTO)
  42. INTEGER JUN
  43. ENDSEGMENT
  44. C
  45. C LECTURE DE LA TABLE ET DE LA TOLERANCE
  46. C
  47. CALL LIROBJ('TABLE',MTABLE,1,IRETOU)
  48. IF(IERR.NE.0) RETURN
  49. CALL LIRREE(TOL,1,IRETOU)
  50. IF(IERR.NE.0) RETURN
  51. C
  52. C VERIFICATION DE LA DIMENSION
  53. C
  54. IF (IDIM.NE.3)THEN
  55. WRITE(IOIMP,*)'J3FAC0: on n"est pas en 3D'
  56. RETURN
  57. ENDIF
  58. C
  59. C VERIFICATIONS DIVERSES
  60. C
  61. SEGACT, MTABLE
  62. MM=MLOTAB
  63. C
  64. NFACE=MM-1
  65. SEGINI,VWORK1
  66. C
  67. NPOINT=0
  68. MM1=NFACE
  69. SEGINI,BLOCOM
  70. C
  71. IIE1=0
  72. if(nbesc.ne.0) segact ipiloc
  73. DO IE1=1,MM
  74. IF (MTABTI(IE1).EQ.'MOT ')THEN
  75. C
  76. C ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU
  77. C
  78. JF=IPCHAR(MTABII(IE1)+1)
  79. ID=IPCHAR(MTABII(IE1))
  80. IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN
  81. WRITE(IOIMP,*)'J3FAC0: un indice de type mot est errone'
  82. GOTO 9999
  83. ENDIF
  84. IF (MTABTV(IE1).NE.'MOT ')THEN
  85. WRITE(IOIMP,*)'J3FAC0: le SOUSTYPE doit etre un MOT'
  86. GOTO 9999
  87. ENDIF
  88. JF=IPCHAR(MTABIV(IE1)+1)
  89. ID=IPCHAR(MTABIV(IE1))
  90. IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN
  91. WRITE(IOIMP,*)'J3FAC0: le SOUSTYPE doit etre LISTE_DE_BLOCS'
  92. GOTO 9999
  93. ENDIF
  94. ELSEIF (MTABTI(IE1).EQ.'ENTIER ')THEN
  95. C
  96. C ON VERIFIE LE CONTENU DES INDICES ENTIERS
  97. C
  98. IF (MTABTV(IE1).NE.'TABLE')THEN
  99. WRITE(IOIMP,*)'J3FAC0: un indice entier n"est pas une table'
  100. GOTO 9999
  101. ENDIF
  102. MTAB1=MTABIV(IE1)
  103. SEGACT,MTAB1
  104. MM1=MTAB1.MLOTAB
  105. C
  106. NFACE=MM1-1
  107. SEGINI,VWORK
  108. IIE1=IIE1+1
  109. VWORK1.FWWORK(IIE1)=VWORK
  110. C
  111. IIE2=0
  112. DO IE2=1,MM1
  113. if(nbesc.ne.0) segact ipiloc
  114. IF (MTAB1.MTABTI(IE2).EQ.'MOT ')THEN
  115. IDM=MTAB1.MTABII(IE2)
  116. JF=IPCHAR(IDM+1)
  117. ID=IPCHAR(IDM)
  118. IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN
  119. WRITE(IOIMP,*)'J3FAC0: pas de sous-type'
  120. GOTO 9999
  121. ENDIF
  122. IF (MTAB1.MTABTV(IE2).NE.'MOT ')THEN
  123. WRITE(IOIMP,*)'J3FAC0: sous-type de type incorrect'
  124. GOTO 9999
  125. ENDIF
  126. IDF=MTAB1.MTABIV(IE2)
  127. JF=IPCHAR(IDF+1)
  128. ID=IPCHAR(IDF)
  129. IF (ICHARA(ID:JF-1).NE.'LISTE_DE_FACES')THEN
  130. WRITE(IOIMP,*)'J3FAC0: sous-type incorrect'
  131. GOTO 9999
  132. ENDIF
  133. ELSEIF (MTAB1.MTABTI(IE2).EQ.'ENTIER ')THEN
  134. IF (MTAB1.MTABTV(IE2).NE.'MAILLAGE')THEN
  135. WRITE(IOIMP,*)'indice entier non maillage'
  136. GOTO 9999
  137. ENDIF
  138. MELEME=MTAB1.MTABIV(IE2)
  139. SEGACT,MELEME
  140. IF(ITYPEL.NE.2)THEN
  141. WRITE(IOIMP,*)'maillage non de seg2'
  142. GOTO 9999
  143. ENDIF
  144. C
  145. NPTO=ICOLOR(/1)
  146. IF(NUM(1,1).NE.NUM(2,NPTO))THEN
  147. WRITE(IOIMP,*)'maillage non ferme'
  148. GOTO 9999
  149. ENDIF
  150. C
  151. NTROU=0
  152. SEGINI,WWORK
  153. C
  154. SEGINI,WORK
  155. FWORK=WORK
  156. IIE2=IIE2+1
  157. FWWORK(IIE2)=WWORK
  158. C
  159. CALL J3LOAD(NUM,WWORK,NPTO,TOL,IRET)
  160. IF(IRET.GT.0)GOTO 9999
  161. CALL J3ORIE(1,XYC,DENS,NPTO,1,TOL,IRET)
  162. IF(IRET.GT.0)GOTO 9999
  163. IF(IIMPI.EQ.1789)THEN
  164. WRITE(IOIMP,*)'J3FAC0:LOAD DE LA FACE ',IIE1,IIE2
  165. CALL J3LIWW(WWORK)
  166. ENDIF
  167. CALL J3LOAP(MELEME,NPTO,BLOCOM,NPOINT)
  168. C
  169. SEGDES,MELEME*NOMOD
  170. ELSE
  171. GOTO 9999
  172. ENDIF
  173. ENDDO
  174. ELSE
  175. WRITE(IOIMP,*)'J3FAC0: un type d"indice est errone'
  176. GOTO 9999
  177. ENDIF
  178. C
  179. C DANS MAILL SE TROUVE LE NOMBRE DE PT TOTAL CHARGE A
  180. C LA FIN DE CHAQUE BLOC
  181. C
  182. IF(IIE1.NE.0)MAILL(IIE1)=NPOINT
  183. ENDDO
  184. if(nbesc.ne.0) SEGDES,IPILOC
  185. C
  186. C ON VERIFIE QUE LES POINTS DE CHAQUE BLOK SONT 2 A 2 DISJOINTS
  187. C
  188. CALL J3DISJ(BLOCOM,TOL,IRET)
  189. IF(IRET.GT.0) GOTO 9999
  190. C
  191. C ON GENERE LA NOUVELLE ARBORESCENCE DE FACE
  192. C
  193. CALL J3FAC1(VWORK1,TOL,IRET)
  194. IF(IRET.GT.0) GOTO 9999
  195. C
  196. C ON TRAITE LES CAS QUI PEUVENT DONNER DU SOUCIS A SURF
  197. C
  198. CALL J3SURE(VWORK1,IRET,TOL)
  199. IF(IRET.GT.0) GOTO 9999
  200. CALL J3SURF(VWORK1,TOL)
  201. C
  202. C ON CHARGE LE RESULTAT DANS LA TABLE DE SORTIE MAIS LES POINTS
  203. C SONT MIS DANS UN BLOCOM
  204. C
  205. BLOCO1=BLOCOM
  206. C
  207. MTAB1=MTABLE
  208. SEGINI,MTABLE=MTAB1
  209. SEGDES,MTAB1*NOMOD
  210. C
  211. MM1=0
  212. NPOINT=0
  213. SEGINI,BLOCOM
  214. C
  215. IIE1=0
  216. DO IE1=1,MM
  217. IF (MTABTI(IE1).EQ.'ENTIER ')THEN
  218. IIE1=IIE1+1
  219. VWORK=VWORK1.FWWORK(IIE1)
  220. M=FWWORK(/1)+1
  221. SEGINI,MTAB1
  222. MTAB1.MLOTAB=M
  223. MTABIV(IE1)=MTAB1
  224. C
  225. IM=1
  226. MTAB1.MTABTI(IM)='MOT '
  227. MTAB1.MTABII(IM)=IDM
  228. MTAB1.MTABTV(IM)='MOT '
  229. MTAB1.MTABIV(IM)=IDF
  230. C
  231. DO IE2=1,M-1
  232. C
  233. WWORK=FWWORK(IE2)
  234. NTROU=TWORK(/1)
  235. WORK=FWORK
  236. C
  237. NBNN=2
  238. NBELEM=XYC(/2)
  239. NBSOUS=0
  240. NBREF=0
  241. SEGINI,MELEME
  242. ITYPEL=2
  243. C
  244. NPOINT1=NPOINT
  245. NPOINT=NPOINT+NBELEM
  246. MM1=MM1+1
  247. SEGADJ,BLOCOM
  248. MAILL(MM1)=MELEME
  249. C
  250. DO IE3=1,NBELEM
  251. JE3=NPOINT1+IE3
  252. DO IE4=1,3
  253. YCOOR(IE4,JE3)=XYC(1,IE3)*VI(IE4)+XYC(2,IE3)*VJ(IE4)
  254. > +PORIG(IE4)
  255. ENDDO
  256. YCOOR(4 ,JE3)=DENS(IE3)
  257. DENS(IE3)=FLOAT(JE3)
  258. POINT(JE3)=JE3
  259. ENDDO
  260. DO IE3=1,NBELEM
  261. NUM(1,IE3)=INT(DENS(IE3))
  262. IF(IE3.EQ.NBELEM)THEN
  263. NUM(2,IE3)=INT(DENS(1))
  264. ELSE
  265. NUM(2,IE3)=INT(DENS(IE3+1))
  266. ENDIF
  267. ICOLOR(IE3)=IDCOUL
  268. ENDDO
  269. C
  270. IF(NTROU.NE.0)THEN
  271. DO IE3=1,NTROU
  272. NBELE1=NBELEM
  273. SEGSUP,WORK
  274. WORK=TWORK(IE3)
  275. NBELE2=XYC(/2)
  276. NBELEM=NBELE1+NBELE2
  277. SEGADJ,MELEME
  278. C
  279. NPOINT1=NPOINT
  280. NPOINT=NPOINT+NBELE2
  281. SEGADJ,BLOCOM
  282. C
  283. DO IE4=1,NBELE2
  284. JE4=NPOINT1+IE4
  285. DO IE5=1,3
  286. YCOOR(IE5,JE4)=XYC(1,IE4)*VI(IE5)+XYC(2,IE4)*VJ(IE5)
  287. > +PORIG(IE5)
  288. ENDDO
  289. YCOOR(4 ,JE4)=DENS(IE4)
  290. DENS(IE4)=FLOAT(JE4)
  291. POINT(JE4)=JE4
  292. ENDDO
  293. DO IE4=1,NBELE2
  294. NUM(1,NBELE1+IE4)=INT(DENS(IE4))
  295. IF(IE4.EQ.NBELE2)THEN
  296. NUM(2,NBELE1+IE4)=INT(DENS(1))
  297. ELSE
  298. NUM(2,NBELE1+IE4)=INT(DENS(IE4+1))
  299. ENDIF
  300. ICOLOR(NBELE1+IE4)=IDCOUL
  301. ENDDO
  302. ENDDO
  303. ENDIF
  304. C
  305. C SEGDES,MELEME
  306. SEGSUP,WORK
  307. C
  308. IM=IM+1
  309. MTAB1.MTABTI(IM)='ENTIER '
  310. MTAB1.MTABII(IM)=IE2
  311. MTAB1.MTABTV(IM)='MAILLAGE'
  312. MTAB1.MTABIV(IM)=MELEME
  313. ENDDO
  314. C SEGDES,MTAB1
  315. SEGSUP,VWORK
  316. C
  317. ENDIF
  318. ENDDO
  319. C SEGDES,MTABLE
  320. SEGSUP,VWORK1
  321. C
  322. C ON AJOUTE MAINTENANT LES POINT QUI TOMBENT SUR DES SEGMENTS
  323. C
  324. CALL J3ARET(BLOCOM,TOL)
  325. C
  326. C ON VERIFIE QUE LES POTS EN VIS A VIS ONT LA MEME DENSITE
  327. C ET ON REND LES COORDONNES IDENTIQUES
  328. C
  329. CALL J3DISK(BLOCOM,TOL,IRET)
  330. IF(IRET.NE.0)THEN
  331. SEGSUP,BLOCOM,BLOCO1,MTABLE
  332. GOTO 9998
  333. ENDIF
  334. C
  335. C ON CHARGE MAINTENANT LES POINTS DANS LA PILE DES POINTS TOUT
  336. C EN ELIMINANT AVEC LES CAS EXISTANT ET EN TRAITANT LES CAS
  337. C TORDUS (POUR SURF)
  338. C
  339. CALL J3UNLO(BLOCOM,BLOCO1,MTABLE,TOL)
  340. SEGSUP,BLOCOM,BLOCO1
  341. C
  342. CALL ECROBJ('TABLE',MTABLE)
  343. C
  344. RETURN
  345. C
  346. 9999 SEGSUP,BLOCOM
  347. CALL J3DETR(VWORK1)
  348. SEGDES,MTABLE*NOMOD
  349. 9998 CALL ERREUR(21)
  350. RETURN
  351. END
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  

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