Télécharger mutu1.eso

Retour à la liste

Numérotation des lignes :

  1. C MUTU1 SOURCE BP208322 15/06/22 21:21:07 8543
  2. SUBROUTINE MUTU1(IPMODE,IPCHEL,IPMAIL,IPRIGI)
  3. ************************************************************************
  4. *
  5. * M U T U 1
  6. * ---------
  7. *
  8. *
  9. * FONCTION:
  10. * ---------
  11. * CREATION DE LA MATRICE DE MUTUELLES
  12. * GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE
  13. *
  14. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+)=CONTENU DANS UN COMMUN
  15. * -----------
  16. *
  17. * IPMODE (E) POINTEUR SUR LE SEGMENT MMODEL
  18. * IPCHEL (E) POINTEUR SUR LE SEGMENT MCHELM
  19. * IPMAIL (E) POINTEUR SUR LE SEGMENT MELEME S'il existe
  20. * IPRIGI (S) POINTEUR SUR LE SEGMENT MRIGID
  21. * +IFOMOD (E) VOIR CCOPTIO
  22. *
  23. * MODULES UTILISES:
  24. * -----------------
  25. *
  26. IMPLICIT INTEGER(I-N)
  27. -INC CCOPTIO
  28. -INC CCHAMP
  29. -INC SMRIGID
  30. -INC SMCHAML
  31. -INC SMELEME
  32. -INC SMMODEL
  33. -INC SMCOORD
  34. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  35. SEGMENT ICPR2(XCOOR(/1)/(IDIM+1))
  36. *
  37. *
  38. * VARIABLES:
  39. * ----------
  40. *
  41. * NBNN NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
  42. * NEF NUMERO DE L'ELEMENT FINI DANS NOMTP
  43. * NBMAIL NOMBRE DE MAILLAGES ELEMENTAIRES
  44. * NBELEM NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
  45. *
  46. LOGICAL OK
  47. CHARACTER*4 MOTHER,MOCHAL
  48. PARAMETER ( MOTHER='FC ' )
  49. PARAMETER ( MOCHAL='ED ' )
  50. *
  51. * AUTEUR, DATE DE CREATION:
  52. * -------------------------
  53. *
  54. * YANN STEPHAN, LE 28 FEVRIER 1997 (COPIE DE RESI1).
  55. *
  56. * LANGAGE:
  57. * --------
  58. *
  59. * ESOPE + FORTRAN77
  60. *
  61. ************************************************************************
  62. *
  63. *
  64. * VERIFICATION DU LIEU SUPPORT DU CHAMELEM DE CARACTERISTIQUES
  65. *
  66. CALL QUESUP(IPMODE,IPCHEL,2,0,ISUP,IRETCA)
  67. IF(ISUP.GT.1)RETURN
  68. *
  69. * SI LE CHAMELEM EST APPUYE AUX NOEUDS ,ON CHANGE LE SUPPORT
  70. * POUR LES CENTRES DE GRAVITE
  71. *
  72. IF(ISUP.EQ.1)THEN
  73. CALL CHASUP(IPMODE,IPCHEL,IPCHE1,IRET,2)
  74. IF(IRET.NE.0)THEN
  75. CALL ERREUR(IRET)
  76. RETURN
  77. ENDIF
  78. ELSE
  79. IPCHE1=IPCHEL
  80. ENDIF
  81. *
  82. * ACTIVATION DES SEGMENTS MCHELM ET MMODEL
  83. *
  84. MCHELM=IPCHE1
  85. SEGACT,MCHELM
  86. NBMAIC=IMACHE(/1)
  87. SEGDES MCHELM
  88. *
  89. MMODEL=IPMODE
  90. SEGACT,MMODEL
  91. NBMAIM=KMODEL(/1)
  92. IF (NBMAIM.GT.NBMAIC) THEN
  93. *
  94. * IL MANQUE LES CARACTERISTIQUES D'UNE OU PLUSIEURS PARTIES
  95. * DU MODELE
  96. *
  97. CALL ERREUR(404)
  98. SEGDES,MMODEL*NOMOD
  99. IF(ISUP.EQ.1)SEGSUP MCHELM
  100. RETURN
  101. ENDIF
  102. *
  103. NBMAIL=NBMAIM
  104. *
  105. * INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
  106. *
  107. NRIGE=8
  108. NRIGEL=1
  109. SEGINI,MRIGID
  110. IPRIGI=MRIGID
  111. ICHOLE=0
  112. IMGEO1=0
  113. IMGEO2=0
  114. IFORIG=IFOMOD
  115. ISUPEQ=0
  116. MTYMAT='RIGIDITE'
  117. NBGEOR=0
  118. NELRIG=1
  119. * SEGINI,xMATRI
  120. IRIGEL(2,1)=0
  121. IRIGEL(4,1)=0
  122. IRIGEL(5,1)=0
  123. IRIGEL(6,1)=0
  124. IRIGEL(7,1)=2
  125. COERIG(1)=1.D0
  126.  
  127. IFOI=0
  128. *
  129. * creation d'une numerotation locale dans le but de creer un
  130. * element unique support de toute la matrice de mutuelle on prend
  131. * d'abord le maillage issu du modele puis on fait la meme chosepour
  132. * celui issu de IPMAIL
  133. *
  134. SEGINI ICPR,ICPR2
  135. IB=0
  136. DO 41 IMAIL=1,NBMAIL
  137. IMODEL=KMODEL(IMAIL)
  138. SEGACT,IMODEL
  139. MELEME=IMAMOD
  140. SEGACT,MELEME
  141. DO 42 I=1,NUM(/2)
  142. DO 42 J=1,NUM(/1)
  143. IA = NUM(J,I)
  144. IF(ICPR(IA).EQ.0) THEN
  145. IB=IB+1
  146. ICPR(IA)=IB
  147. ENDIF
  148. 42 CONTINUE
  149. 41 CONTINUE
  150. IF( IPMAIL.EQ.0) THEN
  151. *
  152. * on travail sur lui meme
  153. *
  154. * on le cree de tel facon qu'il soit identique en structure a
  155. * celui issu du modele
  156. *
  157. DO 65 KI=1,ICPR(/1)
  158. 65 ICPR2(KI)=ICPR(KI)
  159. NBSOUS = NBMAIL
  160. IF( NBSOUS.EQ.1) THEN
  161. IPMAIL=MELEME
  162. ELSE
  163. NBREF=0
  164. NBNN=0
  165. NBELEM=0
  166. SEGINI IPT5
  167. IPMAIL=IPT5
  168. DO 63 KI=1,NBSOUS
  169. IMODEL=KMODEL(KI)
  170. IPT5.LISOUS(KI)=IMAMOD
  171. 63 CONTINUE
  172. ENDIF
  173. ELSE
  174. *
  175. * on a fournit un deuxieme maillage. il faut verifier qu'il y a
  176. * concordance topologique on boucle sur les zones de ce maillage pour
  177. * construire une numerotation et on verifie qu'eele est compatible
  178. * avec l'autre
  179. *
  180. IPT1=IPMAIL
  181. MELEME=IPT1
  182. SEGACT IPT1
  183. IC=0
  184. IH=MAX(1,IPT1.LISOUS(/1))
  185. IF(IH.NE.KMODEL(/1)) THEN
  186. CALL ERREUR(910)
  187. RETURN
  188. ENDIF
  189. DO 43 K=1,MAX(1,IPT1.LISOUS(/1))
  190. IF(IPT1.LISOUS(/1).NE.0) THEN
  191. MELEME= IPT1.LISOUS(K)
  192. SEGACT MELEME
  193. ENDIF
  194. IMODEL=KMODEL(K)
  195. IPT5=IMAMOD
  196. IF( IPT5.NUM(/2).NE.NUM(/2) )THEN
  197. CALL ERREUR(910)
  198. RETURN
  199. ENDIF
  200. IF( IPT5.NUM(/1).NE.NUM(/1) )THEN
  201. CALL ERREUR(910)
  202. RETURN
  203. ENDIF
  204. DO 44 I=1,NUM(/2)
  205. DO 44 J=1,NUM(/1)
  206. IA = NUM(J,I)
  207. IF(ICPR2(IA).EQ.0) THEN
  208. IC=IC+1
  209. ICPR2(IA)=IC
  210. ENDIF
  211. IH=IPT5.NUM(J,I)
  212. IM = ICPR(IH)
  213. IF(IM.NE.ICPR2(IA)) THEN
  214. CALL ERREUR(910)
  215. RETURN
  216. ENDIF
  217. 44 CONTINUE
  218. 43 CONTINUE
  219. ENDIF
  220. * initialisations du maillages support de la mutuelle
  221. NBNN=IB
  222. NBELEM=1
  223. NBSOUS=0
  224. NBREF=0
  225. SEGINI MELEME
  226. ITYPEL=28
  227. DO 49 K=1,ICPR(/1)
  228. IF( ICPR(K).NE.0) THEN
  229. IA = ICPR(K)
  230. NUM(IA,1) = K
  231. ENDIF
  232. 49 CONTINUE
  233. IPRESU=MELEME
  234. IRIGEL(1,1)=MELEME
  235. *
  236. * initialisation du segment descripteur
  237. *
  238. NLIGRP=IB
  239. NLIGRD=IB
  240. SEGINI DESCR
  241. SEGINI XMATRI
  242. * IMATTT(1)=XMATRI
  243. * SEGDES IMATRI
  244. IRIGEL(3,1)=DESCR
  245. irigel(4,1)=xmatri
  246. DO 48 K=1,NLIGRP
  247. LISINC(K)=MOTHER
  248. LISDUA(K)=MOCHAL
  249. NOELEP(K)=K
  250. NOELED(K)=K
  251. 48 CONTINUE
  252. SEGDES DESCR
  253. * Il reste a calculer les matrices (3*3 por les rot3)
  254. * et a les assembler (l'assemblage aura lieu dans rot3M
  255. *
  256. *
  257. * BOUCLE SUR LES MAILLAGES ELEMENTAIRES,ZONE IMAIL
  258. *
  259. DO 50 IMAIL=1,NBMAIL
  260. *
  261. IFOI=IFOI+1
  262. IMODEL=KMODEL(IMAIL)
  263. SEGACT,IMODEL
  264. ICOQ = 0
  265. NEF=NEFMOD
  266. MELEME=IMAMOD
  267. IPT4=IMAMOD
  268. SEGACT,MELEME
  269. NBNNC=NUM(/1)
  270. NBELEC=NUM(/2)
  271. NBELEM=0
  272. IPT1=IPMAIL
  273. SEGACT,IPT1
  274. NBSOUJ=IPT1.LISOUS(/1)
  275. IF(NBSOUJ.EQ.0) NBSOUJ=1
  276. NBNNJ=0
  277. DO 70 ISOUJ=1,NBSOUJ
  278. IF(NBSOUJ.EQ.1) THEN
  279. IPT2=IPT1
  280. ELSE
  281. IPT2=IPT1.LISOUS(ISOUJ)
  282. SEGACT, IPT2
  283. ENDIF
  284. NBELEJ=IPT2.NUM(/2)
  285. NBELEM=NBELEM+NBELEC*NBELEJ
  286. NBNNJ=MAX(NBNNJ,IPT2.NUM(/1))
  287. 70 CONTINUE
  288. *
  289. * LES 2 MAILLAGES DOIVENT AVOIR LE MEME NOMBRE
  290. * DE MAILLES
  291. * IF(NBELEC.NE.NBELEJ) THEN
  292. * write(6,*) ' cest bien ce message 1'
  293. ** CALL ERREUR(21)
  294. * RETURN
  295. * ENDIF
  296. *
  297. *
  298. CALL MUTU3(NEF,IMAIL,IMODEL,IPCHE1,IPMAIL,XMATRI,ICPR,
  299. $ ICPR2)
  300. SEGDES,MELEME*NOMOD
  301. IF (IERR.NE.0)GOTO 99
  302. 50 CONTINUE
  303. SEGDES,MRIGID,XMATRI
  304. 99 CONTINUE
  305. SEGSUP ICPR,ICPR2
  306. DO 60 I=1,IFOI
  307. IMODEL=KMODEL(I)
  308. SEGDES,IMODEL*NOMOD
  309. 60 CONTINUE
  310. * END DO
  311. SEGDES,MMODEL*NOMOD
  312. IF(ISUP.EQ.1)SEGSUP MCHELM
  313. *
  314. RETURN
  315. END
  316.  
  317.  
  318.  
  319.  
  320.  

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