Télécharger racpor.eso

Retour à la liste

Numérotation des lignes :

  1. C RACPOR SOURCE BP208322 16/11/18 21:20:41 9177
  2. C
  3. C FABRIQUE LES ELEMENTS RACCORD POUR LES ELEMENTS JOINT POREUX (BALD).
  4. C CES ELEMENTS JOINTS SONT COMPOSES PAR TROIS LIGNES: LES LIGNES TOP
  5. C ET BOT SONT MAILLEES AVEC DES ELEMENTS SEG3, LA LIGNE AU MILIEU AVEC
  6. C DES SEG2. L'ELEMENT RACCORD CREE A 8 NOEUDS.
  7. C
  8. SUBROUTINE RACPOR(IPT1,IPT2,IPT3,MELEME,PREC)
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC CCGEOME
  15. -INC CCREEL
  16. -INC SMELEME
  17. -INC SMCOORD
  18. SEGMENT MTRAV
  19. REAL*8 TA(NBELEM)
  20. INTEGER NP1(NBELE1),NP2(NBELE1)
  21. ENDSEGMENT
  22. C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME
  23. DIMENSION ITEST(0:30)
  24.  
  25. IDIMP1 = IDIM+1
  26. SEGACT MCOORD
  27. PREC3=3.*PREC
  28. TMAX=-XGRAND
  29. TMIN= XGRAND
  30. NB1=IPT1.NUM(/2)
  31. NB2=IPT2.NUM(/2)
  32. NB3=IPT3.NUM(/2)
  33. NBMAX=MIN(NB1,NB2,NB3)
  34. NBNN=IPT1.NUM(/1)
  35. NBNM=IPT3.NUM(/1)
  36. IF ((NBNN.NE.IPT2.NUM(/1)).OR.(NBNN.EQ.NBNM).OR.
  37. . (NBSOM(IPT1.ITYPEL).NE.NBSOM(IPT3.ITYPEL))) THEN
  38. CALL ERREUR(16)
  39. RETURN
  40. ENDIF
  41. DO 40 I=0,(NBCOUL-1)
  42. ITEST(I)=0
  43. 40 CONTINUE
  44. DO 41 I=1,NB1
  45. ITEST(IPT1.ICOLOR(I))=1
  46. 41 CONTINUE
  47. DO 42 I=1,NB2
  48. ITEST(IPT2.ICOLOR(I))=1
  49. 42 CONTINUE
  50. DO 43 I=1,NB3
  51. ITEST(IPT3.ICOLOR(I))=1
  52. 43 CONTINUE
  53. ICHCOL=-1
  54. DO 44 I=0,(NBCOUL-1)
  55. IF (ITEST(I).EQ.1) THEN
  56. IF (ICHCOL.EQ.-1) THEN
  57. ICHCOL=I
  58. ELSE
  59. ICHCOL=ITABM(ICHCOL,I)
  60. ENDIF
  61. ENDIF
  62. 44 CONTINUE
  63. NBELEM=NB2
  64. NBELE1=NBELEM+1
  65. SEGINI MTRAV
  66. DO 11 I=1,NB2
  67. Z=0.
  68. DO 12 J=1,NBNN
  69. IREF=IPT2.NUM(J,I)*IDIMP1-IDIM
  70. Z=Z+XCOOR(IREF)+XCOOR(IREF+1)
  71. IF (IDIM.NE.2) Z=Z+XCOOR(IREF+2)
  72. 12 CONTINUE
  73. Z=Z/NBNN
  74. TA(I)=Z
  75. IF(Z.GT.TMAX) TMAX=Z
  76. IF(Z.LT.TMIN) TMIN=Z
  77. 11 CONTINUE
  78. C
  79. C CLASSEMENT APPROXIMATIF PAR ' DISTANCE '
  80. C
  81. IF ((ABS(TMAX).GE.XPETIT).AND.(TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6
  82. TMAX=TMAX+1.
  83. TMIN=TMIN-1.
  84. 6 CONTINUE
  85. TDEC=(TMAX-TMIN)/NBELEM*1.0001
  86. N = PREC/TDEC + 1.
  87. C* Boucle 3 redondante avec SEGINI,MTRAV
  88. C* DO 3 I=1,NBELE1
  89. C* 3 NP1(I)=0
  90. DO 4 I=1,NBELEM
  91. IPLA=(TA(I)-TMIN)/TDEC+1.
  92. 4 NP1(IPLA)=NP1(IPLA)+1
  93. DO 400 I=2,NBELE1
  94. 400 NP1(I)=NP1(I-1)+NP1(I)
  95. DO 5 I=1,NBELEM
  96. IPLA=(TA(I)-TMIN)/TDEC+1.
  97. IPLB=NP1(IPLA)
  98. NP1(IPLA)=NP1(IPLA)-1
  99. NP2(IPLB)=I
  100. 5 CONTINUE
  101. C
  102. C DANS NP1 ADDRESSE DU DEBUT DE ZONE
  103. C DANS NP2 NUMERO DES ELEMENTS EN NUMEROTATION LOCALE
  104. C DANS TA DISTANCE DES ELEMENTS
  105. C
  106. C IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES.
  107. NBREF=0
  108. NBSOUS=0
  109. NBNNOR=NBNN
  110. NBNN=2*NBNN+NBNM
  111. NBELEM=NB1+NB2
  112. SEGINI MELEME
  113. IPT4=MELEME
  114. NBT=NBELEM
  115. NBELEM=NB2
  116. NUMELG=0
  117. C
  118. C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI
  119. C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT
  120. C COQUE
  121. C
  122. DO 20 I=1,NB1
  123. ZAA=0.
  124. DO 21 J=1,NBNNOR
  125. IREF=IPT1.NUM(J,I)*IDIMP1-IDIM
  126. ZAA=ZAA+XCOOR(IREF)+XCOOR(IREF+1)
  127. IF (IDIM.NE.2) ZAA=ZAA+XCOOR(IREF+2)
  128. 21 CONTINUE
  129. ZAA=ZAA/NBNNOR
  130. IZO=(ZAA-TMIN)/TDEC+1.
  131. IZO1=IZO-N
  132. IZO2=IZO+N
  133. IF(IZO1.LT.1) IZO1=1
  134. IF(IZO2.GT.NBELEM) IZO2=NBELEM
  135. IF (IZO.LT.0.OR.IZO.GT.NBELE1) GOTO 20
  136. DO 28 IZO=IZO1,IZO2
  137. IDEP=NP1(IZO)+1
  138. IFIN=NP1(IZO+1)
  139. IF(IFIN.LT.IDEP) GO TO 28
  140. DO 23 JFA=IDEP,IFIN
  141. IB=NP2(JFA)
  142. IF(ABS(TA(IB)-ZAA).GT.PREC3) GO TO 23
  143. IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM
  144. DO 24 IK=1,NBNNOR
  145. IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM
  146. IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24
  147. IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24
  148. IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2)
  149. # GOTO 24
  150. ISTA=IK
  151. GO TO 26
  152. 24 CONTINUE
  153. GO TO 23
  154. 26 CONTINUE
  155. ISENS=1
  156. ISTA1=ISTA+1
  157. ISTAA=ISTA
  158. IF (ISTA1.GT.NBNNOR) ISTA1=1
  159. IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM
  160. IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM
  161. Z=XCOOR(IREFA)-XCOOR(IREFB)
  162. IF(ABS(Z).GT.PREC) ISENS=-1
  163. Z=XCOOR(IREFA+1)-XCOOR(IREFB+1)
  164. IF(ABS(Z).GT.PREC) ISENS=-1
  165. IF (IDIM.NE.2) THEN
  166. Z=XCOOR(IREFA+2)-XCOOR(IREFB+2)
  167. IF (ABS(Z).GT.PREC) ISENS=-1
  168. ENDIF
  169. DO 30 IJ=2,NBNNOR
  170. IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM
  171. ISTAA=ISTAA+ISENS
  172. IF (ISTAA.EQ.0) ISTAA=NBNNOR
  173. IF (ISTAA.GT.NBNNOR) ISTAA=1
  174. IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM
  175. DO 32 KLP=1,IDIM
  176. Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1)
  177. IF(ABS(Z).GT.PREC) GO TO 23
  178. 32 CONTINUE
  179. 30 CONTINUE
  180. C
  181. IZC=(ZAA-TMIN)/TDEC+1.
  182. DO 33 IC=1,NB3
  183. ZAC=0.
  184. DO 31 J=1,NBNM
  185. IREF=IPT3.NUM(J,IC)*IDIMP1-IDIM
  186. ZAC=ZAC+XCOOR(IREF)+XCOOR(IREF+1)
  187. IF (IDIM.NE.2) ZAC=ZAC+XCOOR(IREF+2)
  188. 31 CONTINUE
  189. ZAC=ZAC/NBNM
  190. IF(ABS(ZAA-ZAC).GT.PREC3) GO TO 33
  191. C ON VIENT D'IDENTIFIER UN ELEMENT DE RACCOR ON VA LE CREER
  192. IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM
  193. DO 34 IK=1,NBNM
  194. IREFB=IPT3.NUM(IK,IC)*IDIMP1-IDIM
  195. IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 34
  196. IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 34
  197. IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2)
  198. # GOTO 34
  199. ISTC=IK
  200. GO TO 36
  201. 34 CONTINUE
  202. GO TO 33
  203. 36 CONTINUE
  204. ISENT=1
  205. ISTC1=ISTC+1
  206. ISTCC=ISTC
  207. IF (ISTC1.GT.NBNM) ISTC1=1
  208. IREFA=IPT1.NUM(3,I)*IDIMP1-IDIM
  209. IREFB=IPT3.NUM(ISTC1,IC)*IDIMP1-IDIM
  210. Z=XCOOR(IREFA)-XCOOR(IREFB)
  211. IF(ABS(Z).GT.PREC) ISENT=-1
  212. Z=XCOOR(IREFA+1)-XCOOR(IREFB+1)
  213. IF(ABS(Z).GT.PREC) ISENT=-1
  214. IF (IDIM.NE.2) THEN
  215. Z=XCOOR(IREFA+2)-XCOOR(IREFB+2)
  216. IF (ABS(Z).GT.PREC) ISENT=-1
  217. ENDIF
  218. DO 50 IJ=3,NBNNOR,2
  219. IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM
  220. ISTCC=ISTCC+ISENT
  221. IF (ISTCC.EQ.0) ISTCC=NBNM
  222. IF (ISTCC.GT.NBNM) ISTCC=1
  223. IREFB=IPT3.NUM(ISTCC,IC)*IDIMP1-IDIM
  224. DO 52 KLP=1,IDIM
  225. Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1)
  226. IF(ABS(Z).GT.PREC) GO TO 33
  227. 52 CONTINUE
  228. 50 CONTINUE
  229. C CREATION D'UN ELEM RACCORD
  230. NUMELG=NUMELG+1
  231. IF (NUMELG.GT.NBMAX) CALL ERREUR(31)
  232. IF (IERR.NE.0) GOTO 101
  233. IM=0
  234. DO 27 IK=1,NBNNOR
  235. IP1=IPT1.NUM(IK,I)
  236. IP2=IPT2.NUM(ISTA,IB)
  237. NUM(IK,NUMELG)=IP1
  238. NUM(2*NBNNOR-IK+1,NUMELG)=IP2
  239. ISTA=ISTA+ISENS
  240. IF (ISTA.EQ.0) ISTA=NBNNOR
  241. IF (ISTA.GT.NBNNOR) ISTA=1
  242. IF (IK.EQ.IBSOM(NSPOS(IPT1.ITYPEL)+IM)) THEN
  243. IM=IM+1
  244. IP3=IPT3.NUM(ISTC,IC)
  245. NUM(2*NBNNOR+IM,NUMELG)=IP3
  246. ISTC=ISTC+ISENT
  247. IF (ISTC.EQ.0) ISTC=NBNM
  248. IF (ISTC.GT.NBNM) ISTC=1
  249. IF ((IP1.NE.IP2).AND.(IP1.NE.IP3).AND.(IP2.NE.IP3)) GO TO 27
  250. INTERR(1)=NUMELG
  251. CALL ERREUR(101)
  252. ENDIF
  253. IF (IP1.NE.IP2) GO TO 27
  254. INTERR(1)=NUMELG
  255. CALL ERREUR(101)
  256. 27 CONTINUE
  257. 33 CONTINUE
  258. C
  259. 23 CONTINUE
  260. 28 CONTINUE
  261. 20 CONTINUE
  262. C WRITE(IOIMP,29) NUMELG
  263. C 29 FORMAT(//,' NOMBRE D''ELEMENTS DE RACCORD CREES : ',I5)
  264. MELEME=0
  265. NBELEM=NUMELG
  266. IF (NBELEM.EQ.0) THEN
  267. CALL ERREUR(26)
  268. GOTO 101
  269. ENDIF
  270. SEGINI MELEME
  271. IF (NBNN.EQ.8) ITYPEL=29
  272. DO 100 J=1,NBELEM
  273. ICOLOR(J)=ICHCOL
  274. DO 100 I=1,NBNN
  275. NUM(I,J)=IPT4.NUM(I,J)
  276. 100 CONTINUE
  277. 101 SEGSUP IPT4
  278. SEGSUP MTRAV
  279. RETURN
  280. END
  281.  
  282.  
  283.  
  284.  
  285.  

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