Télécharger rot3m.eso

Retour à la liste

Numérotation des lignes :

  1. C ROT3M SOURCE BP208322 15/06/22 21:22:34 8543
  2. SUBROUTINE ROT3M(NEF,IMAIL,IPMODE,IPCHEM,IPSUPJ,XMATRI,
  3. $ ICPR,ICPR2)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. ************************************************************************
  7. *
  8. * R O T 3 M
  9. * ---------
  10. *
  11. * FONCTION:
  12. * ---------
  13. * CALCUL DE LA MATRICE DE MUTUELLES POUR L'ELEMENT ROT3
  14. *
  15. * MODULES UTILISES:
  16. * -----------------
  17. *
  18. -INC CCOPTIO
  19. -INC CCREEL
  20. *-
  21. -INC SMCOORD
  22. -INC SMINTE
  23. -INC CCHAMP
  24. -INC SMMODEL
  25. -INC SMRIGID
  26. -INC SMELEME
  27. -INC SMCHAML
  28. *
  29. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  30. * -----------
  31. *
  32. * NEF (E) NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP)
  33. * IMAIL (E) NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS
  34. * L'OBJET MODELE
  35. * IPMODE (E) POINTEUR SUR UN SEGMENT IMODEL
  36. * IPCHEM (E) POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUE
  37. * IPSUPJ (E) POINTEUR SUR LE MAILLAGE SUPPORT DES COURANTS DE FOUCAULT
  38. * +XCOOR (E) VOIR SMCOORD
  39. * +IDIM (E) VOIR CCOPTIO
  40. * +IFOMOD (E) VOIR CCOPTIO
  41. * +XZERO (E) VOIR CCREEL
  42. * IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE
  43. *
  44. * VARIABLES:
  45. * ----------
  46. *
  47. * NBNN NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
  48. * NEF NUMERO DE L'ELEMENT FINI DANS NOMTP (VOIR CCHAMP)
  49. * NBELEM NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
  50. * NBPGAU NOMBRE DE POINTS DE GAUSS DANS L'ELEMENT-FINI
  51. * NDIM NOMBRE DE LIGNES DE LA MATRICE GRADIENT
  52. * XE(3,NBNN) COORDONNEES DE L'ELEMENT DANS LE REPERE GLOBAL
  53. * SHP(6,NBNN) TABLEAU DE TRAVAIL
  54. * GRAD(NDIM,NBNN) MATRICE GRADIENT DES FONCTIONS DE FORME BIDIM.
  55. * VALMAT(NMATR) TABLEAU DE TRAVAIL
  56. *
  57. SEGMENT MAXT
  58. REAL*8 RA(NBNN,NBNN)
  59. ENDSEGMENT
  60. SEGMENT,MMAT1
  61. REAL*8 VALMAT(NMATR)
  62. REAL*8 XE(3,NBNN),XE1(3,NBNN)
  63. REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN,NBPGAU)
  64. REAL*8 COSD1(3),COSD2(3)
  65. ENDSEGMENT
  66. POINTEUR MMAT2.MMAT1,MMATX.MMAT1
  67. *
  68. SEGMENT NOTYPE
  69. CHARACTER*16 TYPE(NBTYPE)
  70. ENDSEGMENT
  71. *
  72. SEGMENT MPTVAL
  73. INTEGER IPOS(NS) ,NSOF(NS)
  74. INTEGER IVAL(NCOSOU)
  75. CHARACTER*16 TYVAL(NCOSOU)
  76. ENDSEGMENT
  77. *
  78. SEGMENT INFO
  79. INTEGER INFELL(JG)
  80. ENDSEGMENT
  81. *
  82. SEGMENT SGAUSS
  83. REAL*8 XGAUSS(3,NBPGAU)
  84. REAL*8 DX(NBPGAU)
  85. ENDSEGMENT
  86. POINTEUR SGX.SGAUSS,SGY.SGAUSS
  87. SEGMENT ICPR(NA)
  88. SEGMENT ICPR2(NA)
  89. *
  90. CHARACTER*8 CNM
  91. CHARACTER*(NCONCH) CONM
  92. PARAMETER (NINF=3)
  93. INTEGER INFOS(NINF)
  94. LOGICAL SELF,NEAR
  95. *
  96. *
  97. *
  98. * AUTEUR, DATE DE CREATION:
  99. * -------------------------
  100. *
  101. * YANN STEPHAN , FEVRIER 1997 (COPIE DE ROT3R)
  102. *
  103. * LANGAGE:
  104. * --------
  105. *
  106. * ESOPE + FORTRAN77
  107. *
  108. ************************************************************************
  109. * PERMEABILITE DU VIDE SUR 4PI
  110. DATA PM0S4P/1.D-7/
  111. *
  112. * RECUPERATION DES CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE
  113. * ELEMENTAIRE
  114. *
  115. IMODEL=IPMODE
  116. CONM =CONMOD
  117. IPMAIL=IMAMOD
  118. MELEME=IMAMOD
  119. SEGACT,MELEME
  120. NBNN=NUM(/1)
  121. NBELEM=NUM(/2)
  122. *
  123. * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION
  124. * POUR LA MATRICE MUTUELLE (RIGIDITE) DE L'ELEMENT
  125. * FINI LIE A NOTRE MAILLAGE
  126. *
  127. if(infmod(/1).lt.5) then
  128. CALL ELQUOI(NEF,0,3,IPINF,IMODEL)
  129. IF(IERR.NE.0) THEN
  130. SEGDES IMODEL*NOMOD,MELEME*NOMOD
  131. RETURN
  132. ENDIF
  133. INFO=IPINF
  134. IPINTE=INFELL(11)
  135. segsup info
  136. else
  137. ipinte=infmod(5)
  138. endif
  139. *
  140. * INFORMATION SUR L'ELEMENT
  141. *
  142. MINTE=IPINTE
  143. SEGACT,MINTE
  144. NBPGAU=POIGAU(/1)
  145. SEGINI SGX,SGY
  146. *
  147. * RECHERCHE LES POINTEURS DES SEGMENTS MELVAL QUI CORRESPONDENT
  148. * A LA PERMEABILITE ET L'EPAISSEUR DES ELEMENT
  149. *
  150. NFOR=FORMOD(/2)
  151. NMAT=MATMOD(/2)
  152. CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CNM,INM,INT)
  153. IF (IERR.NE.0) THEN
  154. SEGDES,MELEME*NOMOD
  155. SEGDES,MINTE*NOMOD
  156. RETURN
  157. ENDIF
  158. *
  159. * REMLIR LE TABLEAU INFOS (INFORMATIONS SUR ELEMENT)
  160. INFOS(1)=0
  161. INFOS(2)=0
  162. INFOS(3)=NIFOUR
  163. *
  164. IF(CNM.EQ.'ISOTROPE'.OR.CNM.EQ.'ORTHOTRO')THEN
  165. NBRFAC=0
  166. NBROBL=1
  167. SEGINI NOMID
  168. MOMATR=NOMID
  169. LESOBL(1)='PERM'
  170. NMATR=1
  171. NMATF=0
  172. ELSE
  173. CALL ERREUR(251)
  174. SEGDES, MELEME*NOMOD
  175. SEGDES, MINTE*NOMOD
  176. RETURN
  177. ENDIF
  178. SEGDES NOMID
  179. *
  180. NBTYPE=1
  181. SEGINI NOTYPE
  182. MOTYPE=NOTYPE
  183. TYPE(1)='REAL*8'
  184. *
  185. CALL KOMCHA(IPCHEM,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  186. SEGSUP NOTYPE
  187. IF(IERR.NE.0)THEN
  188. SEGDES,MELEME*NOMOD
  189. SEGDES,MINTE*NOMOD
  190. RETURN
  191. ENDIF
  192. *
  193. MPTVAL=IVAMAT
  194. *
  195. NDIM=IDIM
  196. NDIM2=IDIM-1
  197. SEGINI MAXT
  198. SEGINI,MMAT1
  199. MMATX=MMAT1
  200. SEGINI,MMAT2
  201. *
  202. * CALCUL DE LA DISTANCE DE REFERENCE
  203. *
  204. DREF=0.
  205. MIJ=0
  206. DO 20 IEL=1,NBELEM
  207. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  208. CALL MAXLT3(NBNN,XE,DARET)
  209. DREF=MAX(DREF,DARET)
  210. 20 CONTINUE
  211. *
  212. * BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL
  213.  
  214. *
  215. SEGACT ICPR,ICPR2
  216. DO 10 IEL=1,NBELEM
  217.  
  218. *
  219. MMAT1=MMATX
  220. SGAUSS=SGX
  221. *
  222. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL,
  223. * DANS LE REPERE GLOBAL
  224. *
  225. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  226. *
  227. * CALCUL DES COORDONNEES DES NOEUDS DANS LE REPERE LOCAL DE L'
  228. * ELEMENT COQUE
  229. *
  230. CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1)
  231. *
  232. * ON CALCULE LES FONCTIONS DE FORME AUX POINTS DE GAUSS
  233. *
  234. CALL ELGAUS(MINTE,MMAT1,SGAUSS,IFOIS,IFOI2)
  235. *
  236. IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN
  237. *
  238. * LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT
  239. INTERR(1)=IEL
  240. CALL ERREUR(195)
  241. GO TO 999
  242. ELSEIF(IFOI2.EQ.NBPGAU)THEN
  243. *
  244. * CAS OU LE JACOBIEN EST TRES PETIT
  245. *
  246. INTERR(1)=IEL
  247. CALL ERREUR (259)
  248. GO TO 999
  249. ENDIF
  250. *
  251. * ON BOUCLE SUR LE MAILLAGE SUPPORT DE COURANTS
  252. IPT1=IPSUPJ
  253. SEGACT, IPT1
  254. NBSOUJ=IPT1.LISOUS(/1)
  255. IF(NBSOUJ.EQ.0) NBSOUJ=1
  256. DO 110 ISOUJ=1,NBSOUJ
  257. IF(NBSOUJ.EQ.1) THEN
  258. IPT2=IPT1
  259. ELSE
  260. IPT2=IPT1.LISOUS(ISOUJ)
  261. SEGACT, IPT2
  262. ENDIF
  263. NBELJ=IPT2.NUM(/2)
  264. NBNNJ=IPT2.NUM(/1)
  265. NBNNT=NBNN+NBNNJ
  266. NLIGRP=NBNN
  267. NLIGRD=NBNN
  268. DO 111 IELJ=1,NBELJ
  269. DO 230 IX=1,NBNN
  270. DO 230 JX=1,NBNN
  271. 230 RA(JX,IX) = 0.D0
  272. *
  273. NEAR=.FALSE.
  274. *
  275. *
  276. MMAT1=MMAT2
  277. SGAUSS=SGY
  278. *
  279. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL,
  280. * DANS LE REPERE GLOBAL
  281. *
  282. CALL DOXE(XCOOR,IDIM,NBNN,IPT2.NUM,IELJ,XE)
  283. *
  284. * CALCUL DES COORDONNEES DES NOEUDS DANS LE REPERE LOCAL DE L'
  285. * ELEMENT COQUE
  286. *
  287. CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1)
  288. *
  289. CALL ELGAUS(MINTE,MMAT1,SGAUSS,JFOIS,JFOI2)
  290. *
  291. IF(JFOIS.NE.0.AND.JFOIS.NE.NBPGAU)THEN
  292. *
  293. * LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT
  294. INTERR(1)=IEL
  295. CALL ERREUR(195)
  296. GO TO 999
  297. ELSEIF(JFOI2.EQ.NBPGAU)THEN
  298. *
  299. * CAS OU LE JACOBIEN EST TRES PETIT
  300. *
  301. INTERR(1)=IEL
  302. CALL ERREUR (259)
  303. GO TO 999
  304. ENDIF
  305. *
  306. * CALCUL DE LA DISTANCE ENTRE LES DEUX ELEMENTS
  307. *
  308. CALL S2ELT3(NBNN,NUM,IEL,IPT2.NUM,IELJ,NEAR,SELF)
  309. CALL D2ELT3(NBNN,XE,MMATX.XE,DT3)
  310. NEAR=NEAR.OR.(DT3.LE.DREF)
  311. *
  312. * BOUCLE SUR LES POINTS DE GAUSS MAILLAGE 1
  313. *
  314. DO 22 IGAU=1,NBPGAU
  315. *
  316. MMAT1=MMATX
  317. SGAUSS=SGX
  318. *
  319. * ON CHERCHE LES VALEURS DE LA PERMEABILITE
  320. *
  321. MPTVAL=IVAMAT
  322. DO 30 IM=1,NMATR
  323. IF(IVAL(IM).NE.0)THEN
  324. MELVAL=IVAL(IM)
  325. IBMN=MIN(IEL,VELCHE(/2))
  326. IGMN=MIN(IGAU,VELCHE(/1))
  327. VALMAT(IM)=VELCHE(IGMN,IBMN)
  328. ELSE
  329. VALMAT(IM)=0
  330. ENDIF
  331. 30 CONTINUE
  332. PERM=VALMAT(1)
  333. XK=PERM*PM0S4P*DX(IGAU)
  334. *
  335. * BOUCLE SUR LES POINTS DE GAUSS MAILLAGE 2
  336. *
  337. DO 23 JGAU=1,NBPGAU
  338. *
  339. MMAT1=MMAT2
  340. SGAUSS=SGY
  341. *
  342. IF(SELF) THEN
  343. IF(JGAU.GT.1) GO TO 23
  344. CALL SELFT3(SGX.XGAUSS(1,IGAU),NBNN,XE,QQ)
  345. YK=XK*QQ
  346. ELSE IF(NEAR) THEN
  347. IF(JGAU.GT.1) GO TO 23
  348. CALL NEART3(SGX.XGAUSS(1,IGAU),NBNN,MMATX.XE,XE,QQ)
  349. YK=XK*QQ
  350. ELSE
  351. DIST=0.
  352. DO 120 I=1,IDIM
  353. DIST=DIST+(SGX.XGAUSS(I,IGAU)-XGAUSS(I,JGAU))**2
  354. 120 CONTINUE
  355. DIST=SQRT(DIST)
  356. YK=XK*DX(JGAU)/DIST
  357. ENDIF
  358. *
  359. * ON AJOUTE LE PRODUIT K*DJAC*TRANSPOSEE(GRADX)*GRADY
  360. * POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE RE
  361. *
  362. MMAT1=MMATX
  363. CALL WXWYSR(GRAD(1,1,IGAU),MMAT2.GRAD(1,1,JGAU),
  364. & YK,NBNN,NBNNJ,IDIM,RA)
  365. 23 CONTINUE
  366. *
  367. 22 CONTINUE
  368. MIJ=MIJ+1
  369.  
  370. *
  371. *
  372. * realisation de l'assemblage
  373. *
  374. DO 240 IX=1,IPT2.NUM(/1)
  375. IA= IPT2.NUM(IX,IELJ)
  376. IB=ICPR2(IA)
  377. DO 240 JX=1,NUM(/1)
  378. IC=NUM(JX,IEL)
  379. ID=ICPR(IC)
  380. RE(IB,ID,1)=RA(IX,JX) + RE(IB,ID,1)
  381. 240 CONTINUE
  382.  
  383.  
  384.  
  385. *
  386. 111 CONTINUE
  387. 110 CONTINUE
  388. *
  389. 10 CONTINUE
  390. * END DO
  391. * on symetrise la matrice
  392. DO 40 IX=1,RE(/1)
  393. DO 40 JX=1,IX
  394. XP =( RE(IX,JX,1) + RE(JX,IX,1)) / 2.D0
  395. RE(IX,JX,1)=XP
  396. RE(JX,IX,1)=XP
  397. 40 CONTINUE
  398. *
  399. *
  400. * DESACTIVATION DES SEGMENTS
  401. *
  402. 999 CONTINUE
  403. MMAT1=MMATX
  404. SEGSUP,MMAT1,MMAT2
  405. 99 CONTINUE
  406. SEGDES,MELEME*NOMOD
  407. SEGDES,MINTE*NOMOD
  408. * SEGDES,INFO*NOMOD
  409. *
  410. MPTVAL=IVAMAT
  411. DO 50 I=1,NMATR
  412. MELVAL=IVAL(I)
  413. SEGDES,MELVAL
  414. 50 CONTINUE
  415. SEGSUP MPTVAL
  416. NOMID=MOMATR
  417. SEGSUP NOMID,MAXT
  418. *
  419. RETURN
  420. END
  421.  
  422.  
  423.  
  424.  
  425.  
  426.  
  427.  
  428.  
  429.  
  430.  
  431.  
  432.  
  433.  
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  

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