Télécharger liaiso.eso

Retour à la liste

Numérotation des lignes :

  1. C LIAISO SOURCE BP208322 16/11/18 21:18:44 9177
  2. C FABRIQUE LES ELEMENTS LIAISON ENTRE DEUX SURFACES
  3. C D'APRES COCO
  4. C
  5. SUBROUTINE LIAISO(IPT1,IPT2,MELEME,PREC)
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8 (a-h,o-z)
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. -INC CCREEL
  11. *-
  12. -INC SMELEME
  13. -INC SMCOORD
  14.  
  15. SEGMENT MTRAV
  16. REAL*8 TA(NBELEM)
  17. INTEGER NP1(NBELE1),NP2(NBELE1)
  18. ENDSEGMENT
  19.  
  20. C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME
  21. DIMENSION ITEST(0:30)
  22.  
  23. IDIMP1 = IDIM+1
  24. SEGACT MCOORD
  25. PREC3=3.*PREC
  26. TMAX=-XGRAND
  27. TMIN=XGRAND
  28. NB1=IPT1.NUM(/2)
  29. NB2=IPT2.NUM(/2)
  30. NBPOS=MIN(NB1,NB2)
  31. NBNN=IPT1.NUM(/1)
  32. IF (NBNN.NE.IPT2.NUM(/1)) THEN
  33. CALL ERREUR(16)
  34. RETURN
  35. ENDIF
  36. DO 40 I=0,NBCOUL-1
  37. ITEST(I)=0
  38. 40 CONTINUE
  39. DO 41 I=1,NB1
  40. ITEST(min(22,IPT1.ICOLOR(I)))=1
  41. 41 CONTINUE
  42. DO 42 I=1,NB2
  43. ITEST(min(22,IPT2.ICOLOR(I)))=1
  44. 42 CONTINUE
  45. ICHCOL=-1
  46. DO 43 I=0,NBCOUL-1
  47. IF (ITEST(I).EQ.1) THEN
  48. IF (ICHCOL.EQ.-1) THEN
  49. ICHCOL=I
  50. ELSE
  51. ICHCOL=ITABM(ICHCOL,I)
  52. ENDIF
  53. ENDIF
  54. 43 CONTINUE
  55. ITYP=0
  56. IF(IPT1.ITYPEL.EQ.4) ITYP=18
  57. IF(IPT1.ITYPEL.EQ.8) ITYP=19
  58. IF(IPT1.ITYPEL.EQ.6) ITYP=20
  59. IF(IPT1.ITYPEL.EQ.10) ITYP=21
  60. IF (ITYP.EQ.0) RETURN
  61. NBELEM=NB2
  62. NBELE1=NBELEM+1
  63. SEGINI,MTRAV
  64. DO 11 I=1,NB2
  65. Z=0.D0
  66. DO 12 J=1,NBNN
  67. IREF=IPT2.NUM(J,I)*IDIMP1-IDIM
  68. Z=Z+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1))
  69. IF (IDIM.NE.2) Z=Z+ABS(XCOOR(IREF+2))
  70. 12 CONTINUE
  71. Z=Z/NBNN
  72. TA(I)=Z
  73. TMAX=MAX(Z,TMAX)
  74. TMIN=MIN(Z,TMIN)
  75. 11 CONTINUE
  76. C on recommence avec ipt1 pour avoir les vrais TMAX et TMIN
  77. DO 110 I=1,NB1
  78. Z=0.
  79. DO 120 J=1,NBNN
  80. IREF=IPT1.NUM(J,I)*IDIMP1-IDIM
  81. Z=Z+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1))
  82. IF (IDIM.NE.2) Z=Z+ABS(XCOOR(IREF+2))
  83. 120 CONTINUE
  84. Z=Z/NBNN
  85. TMAX=MAX(Z,TMAX)
  86. TMIN=MIN(Z,TMIN)
  87. 110 CONTINUE
  88. C
  89. C CLASSEMENT APPROXIMATIF PAR ' DISTANCE '
  90. C
  91. IF ((TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6
  92. TMAX=TMAX+1.
  93. TMIN=TMIN-1.
  94. 6 CONTINUE
  95. TDEC=(TMAX-TMIN)/NBELEM*1.0001
  96. IF (TDEC.EQ.0.) TDEC=1.
  97. C* Boucle 3 redondante avec SEGINI,MTRAV
  98. C* DO 3 I=1,NBELE1
  99. C* 3 NP1(I)=0
  100. DO 4 I=1,NBELEM
  101. IPLA=INT((TA(I)-TMIN)/TDEC)+1
  102. 4 NP1(IPLA)=NP1(IPLA)+1
  103. DO 400 I=2,NBELE1
  104. 400 NP1(I)=NP1(I-1)+NP1(I)
  105. DO 5 I=1,NBELEM
  106. IPLA=INT((TA(I)-TMIN)/TDEC)+1
  107. IPLB=NP1(IPLA)
  108. NP1(IPLA)=NP1(IPLA)-1
  109. NP2(IPLB)=I
  110. 5 CONTINUE
  111. C
  112. C DANS NP1 ADDRESSE DU DEBUT DE ZONE
  113. C DANS NP2 NUMERO DES ELEMENTS EN NUMEROTATION LOCALE
  114. C DANS TA DISTANCE DES ELEMENTS
  115. C
  116. C IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES.
  117. NBREF=0
  118. NBSOUS=0
  119. NBNNOR=NBNN
  120. NBNN=2*NBNN
  121. NBELEM=NB1+NB2
  122. SEGINI MELEME
  123. IPT4=MELEME
  124. NBT=NBELEM
  125. NBELEM=NB2
  126. NUMELG=0
  127. ittes=0
  128. C
  129. C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI
  130. C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT
  131. C COQUE
  132. DO 20 I=1,NB1
  133. ZAA=0.
  134. DO 21 J=1,NBNNOR
  135. IREF=IPT1.NUM(J,I)*IDIMP1-IDIM
  136. ZAA=ZAA+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1))
  137. IF (IDIM.NE.2) ZAA=ZAA+ABS(XCOOR(IREF+2))
  138. 21 CONTINUE
  139. ZAA=ZAA/NBNNOR
  140. zaami= zaa - idim*prec
  141. zaama= zaa + idim *prec
  142. IZO=(ZAA-TMIN)/TDEC+1.
  143. IZO1=IZO-1
  144. IZO2=IZO+1
  145. izo1= (ZAAmi-TMIN)/TDEC -1
  146. izo2= (ZAAma-TMIN)/TDEC+2
  147. IF(IZO1.LT.1) IZO1=1
  148. IF(IZO2.GT.NBELEM) IZO2=NBELEM
  149. DO 28 IZO=IZO1,IZO2
  150. IDEP=NP1(IZO)+1
  151. IFIN=NP1(IZO+1)
  152. IF(IFIN.LT.IDEP) GO TO 28
  153. DO 23 JFA=IDEP,IFIN
  154. IB=NP2(JFA)
  155. IF(ABS(TA(IB)-ZAA).GT.PREC3) GO TO 23
  156. C ON VIENT D'IDENTIFIER UN ELEMENT DE RACCORD ON VA LE CREER
  157. IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM
  158. DO 24 IK=1,NBNNOR
  159. IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM
  160. IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24
  161. IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24
  162. IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2)
  163. # GOTO 24
  164. ISTA=IK
  165. GO TO 26
  166. 24 CONTINUE
  167. GO TO 23
  168. 26 CONTINUE
  169. ISENS=1
  170. ISTA1=ISTA+1
  171. ISTAA=ISTA
  172. IF (ISTA1.GT.NBNNOR) ISTA1=1
  173. IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM
  174. IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM
  175. Z=XCOOR(IREFA)-XCOOR(IREFB)
  176. IF(ABS(Z).GT.PREC) ISENS=-1
  177. Z=XCOOR(IREFA+1)-XCOOR(IREFB+1)
  178. IF(ABS(Z).GT.PREC) ISENS=-1
  179. IF (IDIM.NE.2) THEN
  180. Z=XCOOR(IREFA+2)-XCOOR(IREFB+2)
  181. IF (ABS(Z).GT.PREC) ISENS=-1
  182. ENDIF
  183. DO 30 IJ=2,NBNNOR
  184. IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM
  185. ISTAA=ISTAA+ISENS
  186. IF (ISTAA.EQ.0) ISTAA=NBNNOR
  187. IF (ISTAA.GT.NBNNOR) ISTAA=1
  188. IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM
  189. DO 32 KLP=1,IDIM
  190. Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1)
  191. IF(ABS(Z).GT.PREC) GO TO 23
  192. 32 CONTINUE
  193. 30 CONTINUE
  194. C CREATION D'UN ELEM RACCORD
  195. NUMELG=NUMELG+1
  196. IF (NUMELG.GT.NBPOS) THEN
  197. CALL ERREUR(31)
  198. GOTO 101
  199. ENDIF
  200. DO 27 IK=1,NBNNOR
  201. IP1=IPT1.NUM(IK,I)
  202. IP2=IPT2.NUM(ISTA,IB)
  203. NUM(IK,NUMELG)=IP1
  204. NUM(NBNNOR+IK,NUMELG)=IP2
  205. ISTA=ISTA+ISENS
  206. IF (ISTA.EQ.0) ISTA=NBNNOR
  207. IF (ISTA.GT.NBNNOR) ISTA=1
  208. IF (IP1.NE.IP2) GOTO 27
  209. INTERR(1)=NUMELG
  210. CALL ERREUR(101)
  211. 27 CONTINUE
  212. 23 CONTINUE
  213. 28 CONTINUE
  214. 20 CONTINUE
  215. IF (IIMPI.NE.0) WRITE(IOIMP,29) NUMELG
  216. 29 FORMAT(///,39H NOMBRE D'ELEMENTS DE LIAISON CREES : ,I5 )
  217. NBELEM=NUMELG
  218. MELEME=0
  219. IF (NBELEM.EQ.0) GOTO 101
  220. SEGINI MELEME
  221. ITYPEL=ITYP
  222. DO 100 J=1,NBELEM
  223. ICOLOR(J)=ICHCOL
  224. DO 100 I=1,NBNN
  225. NUM(I,J)=IPT4.NUM(I,J)
  226. 100 CONTINUE
  227. 101 SEGSUP IPT4
  228. SEGSUP,MTRAV
  229. RETURN
  230. END
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  

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