Télécharger cfnd.eso

Retour à la liste

Numérotation des lignes :

  1. C CFND SOURCE GG250959 17/09/20 21:15:09 9554
  2. subroutine cfnd
  3.  
  4. implicit real*8(a-h,o-z)
  5. implicit integer (i-n)
  6. * rendre un chpoint compatible avec des relations de conformités
  7.  
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. -INC CCHAMP
  11.  
  12. -INC SMMODEL
  13. -INC SMELEME
  14. -INC SMCHPOI
  15. -INC SMRIGID
  16.  
  17. logical ltelq
  18. * Petit tableau des "couleurs" des relations de conformite
  19. DIMENSION LCOLOR(6)
  20. DATA LCOLOR / 1, 3, 6, 10, 16, 24 /
  21.  
  22. call lirobj('MMODEL ',mmodel,1,iretou)
  23. if(ierr.ne.0) return
  24. call lirobj('CHPOINT ',mchpoi,1,iretou)
  25. if(ierr.ne.0) return
  26.  
  27. segact,mmodel
  28. nmsous = kmodel(/1)
  29. ncofo = 0
  30. do ia = 1, nmsous
  31. imodel=kmodel(ia)
  32. segact imodel
  33. if (nefmod.eq.22) ncofo = ncofo+1
  34. if (nefmod.eq.259) ncofo = ncofo+1
  35. enddo
  36. if (ncofo.eq.0) then
  37. segini,mchpo1=mchpoi
  38. segdes,mchpo1
  39. irat = mchpo1
  40. goto 100
  41. endif
  42. *
  43. * il existe des relations de conformités
  44. *
  45. * verif le chpoint n'a qu'une seule zone
  46. segact,mchpoi
  47. if (ipchp(/1).ne.1) then
  48. call erreur (21)
  49. segdes,mchpoi
  50. return
  51. endif
  52. *
  53. * on fabrique les matrices de liaisons et un maillage contenant
  54. * les noeuds dépendants
  55. nrigel = ncofo
  56. segini,RI6
  57. RI6.ICHOLE=0
  58. RI6.IMGEO1=0
  59. RI6.IMGEO2=0
  60. RI6.IFORIG=0
  61. RI6.ISUPEQ=0
  62.  
  63. nbnn = 1
  64. nbsous = 0
  65. nbref = 0
  66. ltelq=.false.
  67.  
  68. ncofo = 0
  69. do ia = 1, nmsous
  70. imodel=kmodel(ia)
  71. if ((nefmod.ne.22).AND.(nefmod.NE.259)) goto 90
  72. ncofo = ncofo+1
  73.  
  74. ipt2=imamod
  75. SEGACT IPT2
  76. nbnoe2 = ipt2.num(/1)
  77. nbele2 = ipt2.num(/2)
  78.  
  79. nbelem = nbele2
  80. segini,meleme
  81. do ib = 1, nbelem
  82. num(1,ib) = ipt2.num(2,ib)
  83. enddo
  84. IDEBUT = LCOLOR(ipt2.icolor(1)) - 3
  85. segdes,ipt2
  86.  
  87. if (ncofo.eq.1) then
  88. ipt1=meleme
  89. segdes,meleme
  90. else
  91. call fuse (ipt1,meleme,ipt3,ltelq)
  92. ipt1=ipt3
  93. endif
  94.  
  95. C====================
  96. C *** SEGMENT XMATRI
  97. C====================
  98. NLIGRD = nbnoe2
  99. NLIGRP = nbnoe2
  100. nelrig = nbele2
  101. SEGINI XMATR6
  102. do 34 i = 1,nelrig
  103. DO 36 ICAZ = 3, nbnoe2
  104. XMATR6.RE(1,ICAZ,i) = XCOEFF(IDEBUT+ICAZ)
  105. XMATR6.RE(ICAZ,1,i) = XMATR6.RE(1,ICAZ,i)
  106. 36 CONTINUE
  107. XMATR6.RE(1,2,i)=-1.D0
  108. XMATR6.RE(2,1,i)=-1.D0
  109. 34 continue
  110. SEGDES,XMATR6
  111. C====================
  112. C *** SEGMENT DESCR
  113. C====================
  114. nomid=lnomid(1)
  115. segact,nomid
  116. NEXIST = 0
  117. DO 33 I=1, LNOMDD
  118. IF (NOMDD(I).EQ.nomid.lesobl(1)) NEXIST = I
  119. 33 CONTINUE
  120. segdes,nomid
  121. IF (NEXIST.EQ.0) THEN
  122. CALL ERREUR(837)
  123. RETURN
  124. ENDIF
  125. c* NLIGRD=nbnoe2
  126. c* NLIGRP=NLIGRD
  127. SEGINI,DES1
  128. DES1.LISINC(1)='LX '
  129. DES1.LISDUA(1)='FLX '
  130. DES1.NOELEP(1)=1
  131. DES1.NOELED(1)=1
  132. DO 35 I=2,NLIGRD
  133. DES1.LISINC(I)=NOMDD(NEXIST)
  134. DES1.LISDUA(I)=NOMDU(NEXIST)
  135. DES1.NOELEP(i)=i
  136. DES1.NOELED(i)=i
  137. 35 CONTINUE
  138. SEGDES,DES1
  139. C====================
  140. C *** SEGMENT MRIGID
  141. C====================
  142. RI6.COERIG(ncofo)=1.D0
  143. RI6.IRIGEL(1,ncofo)=IPT2
  144. * RI6.IRIGEL(2,ncofo)=0
  145. RI6.IRIGEL(3,ncofo)=DES1
  146. RI6.IRIGEL(4,ncofo)=xMATR6
  147. * RI6.IRIGEL(5,ncofo)=0
  148. * RI6.IRIGEL(6,ncofo)=0
  149. * RI6.IRIGEL(7,ncofo)=0
  150. * RI6.IRIGEL(8,ncofo)=0
  151.  
  152. 90 continue
  153. segdes,imodel
  154.  
  155. enddo
  156.  
  157. call depen3(ri6,ri1)
  158. * call prrigi(ri1,0)
  159. * write(ioimp,*) ' chpoint initial'
  160. * call ecchpo (mchpoi,0)
  161. call mucpri (mchpoi,ri1,mchpo2)
  162. * write(ioimp,*) ' chpoint apres mucpri'
  163. * call ecchpo (mchpo2,0)
  164. call reduir(mchpoi,ipt1,mchpo3)
  165. * write(ioimp,*) ' valeurs initiales à reajuster'
  166. * call ecchpo(mchpo3,0)
  167. call adchpo(mchpoi,mchpo3,mchpo4,1.d0,-1.d0)
  168. if (mchpo4.eq.0) return
  169. call adchpo(mchpo4,mchpo2,irat, 1.d0,1.d0)
  170. if (irat.eq.0) return
  171. * write(ioimp,*) ' sortie de cfnd'
  172. * call ecchpo(irat,0)
  173. segsup,ipt1
  174. segsup,ri6,ri1
  175.  
  176. 100 continue
  177. segdes,mmodel
  178. call ecrobj('CHPOINT',irat)
  179.  
  180. return
  181. end
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  

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