Télécharger j3fac0.eso

Retour à la liste

Numérotation des lignes :

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

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