Télécharger bmtd.eso

Retour à la liste

Numérotation des lignes :

  1. C BMTD SOURCE CHAT 11/03/16 21:15:45 6902
  2. SUBROUTINE BMTD
  3. C-----------------------------------------------------------------------
  4. C -1 t
  5. C Calcul du produit B M D CHPcentre
  6. C le résultat est un CHPface
  7. C-----------------------------------------------------------------------
  8. C
  9. C---------------------------
  10. C Phrase d'appel (GIBIANE) :
  11. C---------------------------
  12. C
  13. C CHP2 = 'BMTD' MMODEL RIG1 CHP1 ;
  14. C
  15. C------------------------
  16. C Operandes et resultat :
  17. C------------------------
  18. C
  19. C MMODEL : MODELE permettant de récuperer la TABLE DOMAINE
  20. C contenant les maillages et les connectivités.
  21. C On attend un modèle DARCY
  22. C RIG1 : Matrices hybrides elementaires de DARCY crees par MHYB.
  23. C CHP1 : CHPO centre à plusieur composantes.
  24. C CHP2 : CHPO face à plusieur composantes dont le support géometrique
  25. C est le maillage de la rigidité les noms des composantes
  26. C sont ceux de CHP1
  27. C
  28. C-----------------------------------------------------------------------
  29. C
  30. C Langage : ESOPE + FORTRAN77
  31. C
  32. C
  33. C-----------------------------------------------------------------------
  34. IMPLICIT INTEGER(I-N)
  35. IMPLICIT REAL*8 (A-H,O-Z)
  36. *
  37. -INC CCOPTIO
  38. -INC SMCOORD
  39. -INC SMCHPOI
  40. -INC SMELEME
  41. -INC SMRIGID
  42. -INC SMTABLE
  43. -INC SMMODEL
  44. *
  45. SEGMENT ICCPR
  46. INTEGER ICPR(NNGOT)
  47. ENDSEGMENT
  48. *
  49. LOGICAL LOGRE,LOGIN
  50. CHARACTER*8 TAPIND,CHARRE,LETYPE
  51. CHARACTER*4 NOMTOT(1)
  52. *
  53. * Initialisations
  54. *
  55. IVALIN = 0
  56. XVALIN = 0.D0
  57. LOGIN = .TRUE.
  58. IOBIN = 0
  59. TAPIND = 'MOT '
  60. *
  61. *
  62. * Lecture du MMODEL
  63. *
  64. CALL LIROBJ('MMODEL',IPMODE,1,IRET)
  65. IF(IERR.NE.0)RETURN
  66. MMODEL=IPMODE
  67. SEGACT MMODEL
  68. N1=KMODEL(/1)
  69. DO 7 I=1,N1
  70. IMODEL=KMODEL(I)
  71. SEGACT IMODEL
  72. IF(FORMOD(1).NE.'DARCY')THEN
  73. MOTERR(1:16) = 'DARCY '
  74. CALL ERREUR(719)
  75. RETURN
  76. ENDIF
  77. 7 CONTINUE
  78. C on récupère la table DOMAINE
  79. IPTABL = 0
  80. CALL LEKMOD(MMODEL,IPTABL,IRET)
  81. IF (IERR.NE.0) RETURN
  82. *
  83. CALL LEKTAB(IPTABL,'ELTFA',IOBRE)
  84. IF (IERR.NE.0) RETURN
  85. IELTFA = IOBRE
  86. CALL LEKTAB(IPTABL,'CENTRE',IOBRE)
  87. IF (IERR.NE.0) RETURN
  88. ICENTR = IOBRE
  89. CALL LEKTAB(IPTABL,'FACE',IOBRE)
  90. IF (IERR.NE.0) RETURN
  91. IFACE = IOBRE
  92. *
  93. * Lecture de RIGIDITE
  94. *
  95. CALL LIROBJ('RIGIDITE',IPRIGI,1,IRET)
  96. IF (IERR.NE.0) RETURN
  97. MRIGID = IPRIGI
  98. *
  99. *
  100. *
  101. * Test du sous-type de la matrice de rigiditée récupérée
  102. *
  103. SEGACT MRIGID
  104. LETYPE = MTYMAT
  105. IF (LETYPE.NE.'DARCY') THEN
  106. MOTERR(1:8) = 'RIGIDITE'
  107. MOTERR(9:16) = 'DARCY '
  108. CALL ERREUR(79)
  109. SEGDES MRIGID
  110. GOTO 100
  111. ENDIF
  112. *
  113. * Controle des pointeurs de MELEME de la rigidité
  114. *
  115. NRIGEL=IRIGEL(/2)
  116. MELEME=IELTFA
  117. SEGACT MELEME
  118. NBSOUS=LISOUS(/1)
  119. IF(NBSOUS.EQ.0)THEN
  120. IF((NRIGEL.NE.1).OR.(IRIGEL(1,1).NE.MELEME))THEN
  121. MOTERR(1:8) = 'DARCY '
  122. MOTERR(9:16) = 'ELTFA '
  123. INTERR(1) = 1
  124. CALL ERREUR(698)
  125. SEGDES MRIGID
  126. GOTO 100
  127. ENDIF
  128. ELSE
  129. IF(NRIGEL.NE.NBSOUS)THEN
  130. MOTERR(1:8) = 'DARCY '
  131. MOTERR(9:16) = 'ELTFA '
  132. INTERR(1) = 1
  133. CALL ERREUR(698)
  134. SEGDES MRIGID
  135. GOTO 100
  136. ENDIF
  137. DO 10 ISOUS=1,NBSOUS
  138. IF (LISOUS(ISOUS).NE.IRIGEL(1,ISOUS)) THEN
  139. MOTERR(1:8) = 'DARCY '
  140. MOTERR(9:16) = 'ELTFA '
  141. INTERR(1) = ISOUS
  142. CALL ERREUR(698)
  143. SEGDES MRIGID
  144. GOTO 100
  145. ENDIF
  146. 10 CONTINUE
  147. ENDIF
  148. CALL LIROBJ('CHPOINT',IPCHC,1,IRET)
  149. IF(IRET.NE.1) RETURN
  150. MCHPO1=IPCHC
  151. NOMTOT(1)=' '
  152. NBCOMP=-1
  153. CALL QUEPOI(MCHPO1,ICENTR,INDIC,NBCOMP,NOMTOT)
  154. IF(IERR.NE.0)RETURN
  155. SEGACT MCHPO1
  156. MSOUP1=MCHPO1.IPCHP(1)
  157. SEGACT MSOUP1
  158. MPOVA1=MSOUP1.IPOVAL
  159. SEGACT MPOVA1
  160. *
  161. * Construction de MCHPOI
  162. *
  163. *
  164. IPT2=IFACE
  165. SEGACT IPT2
  166. NPN=IPT2.NUM(/2)
  167. NSOUPO=1
  168. NAT=1
  169. SEGINI MCHPOI
  170. MTYPOI=' '
  171. MOCHDE=' CHPOIN CREE PAR BMTD '
  172. IFOPOI=IFOUR
  173. JATTRI(1)=2
  174. NC=NBCOMP
  175. SEGINI MSOUPO
  176. IPCHP(1)=MSOUPO
  177. DO 5 L=1,NBCOMP
  178. NOCOMP(L)=MSOUP1.NOCOMP(L)
  179. NOHARM(L)=MSOUP1.NOHARM(L)
  180. 5 CONTINUE
  181. IGEOC=IFACE
  182. N=NPN
  183. SEGINI MPOVAL
  184. IPOVAL=MPOVAL
  185. NB=N*NC
  186. CALL INITD(VPOCHA,NB,0.D0)
  187. *
  188. * Creation du tableau ICPR
  189. *
  190. IK = 0
  191. NNGOT = XCOOR(/1)/(IDIM+1)
  192. SEGINI ICCPR
  193. C MELEME = IFACE
  194. C SEGACT MELEME
  195. N2 = IPT2.NUM(/2)
  196. DO 15 I2=1,N2
  197. K = IPT2.NUM(1,I2)
  198. IF (ICPR(K).EQ.0) THEN
  199. IK = IK + 1
  200. ICPR(K) = IK
  201. ENDIF
  202. 15 CONTINUE
  203. SEGDES IPT2
  204. C
  205. C Calcul du produit
  206. C
  207. ITELEM=0
  208. MELEME=IELTFA
  209. C call ecmail(meleme)
  210. SEGACT MELEME
  211. IPT1=MELEME
  212. DO 50 ISOUS=1,NRIGEL
  213. IF(NRIGEL.NE.1)IPT1= LISOUS(ISOUS)
  214. SEGACT IPT1
  215. xMATRI=IRIGEL(4,ISOUS)
  216. SEGACT xMATRI
  217. NELRIG=re(/3)
  218. DO 60 IEL=1,NELRIG
  219. ITELEM=ITELEM+1
  220. * XMATRI=IMATTT(IEL)
  221. * SEGACT XMATRI
  222. NLIGRD=RE(/1)
  223. NLIGRP=RE(/2)
  224. DO 40 I=1,NLIGRD
  225. RLIGN=0.D0
  226. DO 30 J=1,NLIGRP
  227. RLIGN=RLIGN+RE(I,J,iel)
  228. 30 CONTINUE
  229. IPOPTS=ICPR(IPT1.NUM(I,IEL))
  230. DO 20 K=1,NBCOMP
  231. VPOCHA(IPOPTS,K)=VPOCHA(IPOPTS,K)+RLIGN*
  232. * MPOVA1.VPOCHA(ITELEM,K)
  233. 20 CONTINUE
  234.  
  235. 40 CONTINUE
  236. * SEGDES XMATRI
  237. 60 CONTINUE
  238. SEGDES xMATRI
  239. SEGDES IPT1
  240. 50 CONTINUE
  241. IF(NRIGEL.NE.1)SEGDES MELEME
  242. SEGDES MRIGID
  243. CALL ECROBJ('CHPOINT',MCHPOI)
  244. *
  245. * Ménage
  246. *
  247. SEGSUP ICCPR
  248. SEGDES MPOVAL,MSOUPO,MCHPOI
  249. SEGDES MPOVA1,MSOUP1,MCHPO1
  250. 100 CONTINUE
  251. RETURN
  252. END
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  

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