Télécharger frvisq.eso

Retour à la liste

Numérotation des lignes :

  1. C FRVISQ SOURCE CB215821 19/07/30 21:16:32 10273
  2.  
  3. SUBROUTINE FRVISQ(IPMODL,JPMAIL,IPCHE1, IPRIG)
  4. C
  5. C***********************************************************************
  6. C *
  7. C Routine principale appelée par AMOR *
  8. C *
  9. C Calcule la matrice d'amortissement associée à la frontière du *
  10. C maillage dans plusieurs cas : *
  11. C *
  12. C FORMULATION MECANIQUE *
  13. C +++++++++++++++++++++ *
  14. C *
  15. C * cas des massifs, dont l'enveloppe est constituée de SEG2 ou *
  16. C SEG3 (cas 2D), FAC3, FAC4, FAC6, ou FAC8 (cas 3D) *
  17. C *
  18. C FORMULATION LIQUIDE *
  19. C +++++++++++++++++++ *
  20. C *
  21. C * cas des éléments dont l'enveloppe est constituée d'éléments *
  22. C à 2 (cas 2D), 3 ou 4 noeuds (cas 3D). *
  23. C______________________________________________________________________*
  24. C *
  25. C Entrées : *
  26. C -------- *
  27. C *
  28. C IPMODL : pointeur sur le modèle, objet MMODEL *
  29. C JPMAIL : pointeur sur le maillage de la frontière, objet MELEME *
  30. C IPCHE1 : pointeur sur le champ par éléments de caractéristiques *
  31. C matériau, objet MCHAML *
  32. C Sorties : *
  33. C -------- *
  34. C IPRIG : pointeur sur la matrice d'amortissement construite, *
  35. C objet MRIGID (=0 en cas d'erreur) *
  36. C *
  37. C***********************************************************************
  38. C
  39. IMPLICIT INTEGER(I-N)
  40. IMPLICIT REAL*8(A-H,O-Z)
  41. C
  42. -INC CCOPTIO
  43. -INC CCHAMP
  44.  
  45. -INC SMCOORD
  46. -INC SMELEME
  47. -INC SMMODEL
  48. -INC SMCHAML
  49. -INC SMRIGID
  50. -INC SMINTE
  51. C
  52. INTEGER oooval
  53.  
  54. SEGMENT INFO
  55. INTEGER INFELL(JG)
  56. ENDSEGMENT
  57. C
  58. SEGMENT NOTYPE
  59. CHARACTER*16 TYPE(NBTYPE)
  60. ENDSEGMENT
  61. C
  62. SEGMENT MPTVAL
  63. INTEGER IPOS(NS),NSOF(NS)
  64. INTEGER IVAL(NCOSOU)
  65. CHARACTER*16 TYVAL(NCOSOU)
  66. ENDSEGMENT
  67. C
  68. CHARACTER*(NCONCH) CONM
  69.  
  70. C Support du champ de caracteristiques
  71. PARAMETER ( IPLAZ=3 )
  72.  
  73. PARAMETER (NINF=3)
  74. INTEGER INFOS(NINF)
  75. C
  76. IPRIG = 0
  77.  
  78. IF (IFOUR.EQ.-3) THEN
  79. CALL ERREUR(21)
  80. RETURN
  81. ENDIF
  82.  
  83. c_______________________________________________________________________
  84. c
  85. c activation du modele
  86. c_______________________________________________________________________
  87. C
  88. MMODEL=IPMODL
  89. SEGACT MMODEL
  90. NSOUS=KMODEL(/1)
  91.  
  92. C______________________________________________________________________C
  93. C C
  94. C CREATION DE L'OBJET MATRICE DE RIGIDITE C
  95. C______________________________________________________________________C
  96. C C
  97. NRIGEL=0
  98. SEGINI,MRIGID
  99. MTYMAT='RIGIDITE'
  100. IFORIG=IFOMOD
  101. ICHOLE=0
  102. IMGEO1=0
  103. IMGEO2=0
  104. ISUPEQ=0
  105. JRCOND=0
  106. JRDEPP=0
  107. JRDEPD=0
  108.  
  109. C______________________________________________________________________C
  110. C C
  111. C BOUCLE SUR LES SOUS ZONES C
  112. C______________________________________________________________________C
  113. C C
  114. DO 100 ISOUS = 1, NSOUS
  115. C
  116. C on récupère l'information générale
  117. C
  118. IMODEL = KMODEL(ISOUS)
  119. SEGACT,IMODEL
  120.  
  121. C- Initialisations
  122. IENVEL = 0
  123. IPOGEO = 0
  124.  
  125. IPT1 = IMAMOD
  126. CONM = CONMOD
  127. MELM = NEFMOD
  128. C
  129. C création du tableau info
  130. C
  131. iret = 1
  132. CALL IDENT(IPT1,CONM,IPCHE1,0,INFOS,iret)
  133. IF (iret.EQ.0) GOTO 1099
  134. C
  135. C Determination de l'enveloppe du maillage massif du sous-modele
  136. C
  137. CALL ECROBJ('MAILLAGE',IPT1)
  138. IF (IDIM.EQ.3) THEN
  139. CALL ENVELO
  140. ELSE IF (IDIM.EQ.2) THEN
  141. CALL PRCONT
  142. ELSE
  143. CALL ERREUR(5)
  144. ENDIF
  145. IF (IERR.NE.0) GOTO 1099
  146. CALL LIROBJ('MAILLAGE',IENVEL,1,iret)
  147. IF (IERR.NE.0) GOTO 1099
  148. C
  149. C Elements de l'enveloppe IENVEL dans le maillage frontiere JPMAIL
  150. C
  151. iret = 0
  152. CALL INTERB(IENVEL,JPMAIL,iret,IPOGEO)
  153. IF (iret.GT.0) GOTO 1099
  154.  
  155. IPT3 = IPOGEO
  156. SEGACT,IPT3
  157. NBSOU3 = IPT3.LISOUS(/1)
  158. IPT2 = IPT3
  159. C
  160. C boucle sur les sous-zones de l'enveloppe
  161. C
  162. DO 110 IB = 1, MAX(1,NBSOU3)
  163.  
  164. C-- Initialisations :
  165. MOFORC = 0
  166. MODEPL = 0
  167. IPMINT = 0
  168. MOMATR = 0
  169. MOCARA = 0
  170. MOTYPM = 0
  171. MOTYPC = 0
  172. ISUPM = 0
  173. ISUPC = 0
  174. IDESCR = 0
  175.  
  176. C-- Informations sur la (sous-zone de) l'enveloppe
  177. IF (NBSOU3.NE.0) THEN
  178. IPT2 = IPT3.LISOUS(IB)
  179. SEGACT,IPT2
  180. ENDIF
  181. NBNOE2 = IPT2.NUM(/1)
  182. NBELE2 = IPT2.NUM(/2)
  183. LETYP = IPT2.ITYPEL
  184. C-- Petit test sur le type
  185. IF (LETYP.EQ.1) THEN
  186. CALL ERREUR(16)
  187. GOTO 1199
  188. ENDIF
  189. IPOGEO = IPT2
  190. C
  191. C-- On détermine la formulation associée à l'objet géométrique
  192. C-- elementaire de surface
  193. CALL TYPFAC(MELM,NBNOE2,MELE)
  194. C
  195. C-- ERREUR : impossible d'utiliser FROABS pour les éléments
  196. C-- de formulation MELM
  197. IF (MELE.EQ.0) THEN
  198. MOTERR(1:8) = NOMTP(MELM)
  199. CALL ERREUR(193)
  200. GOTO 1199
  201. ENDIF
  202.  
  203. C-- Information sur l'élément fini
  204. CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  205. IF (IERR.NE.0) GOTO 1199
  206. C
  207. INFO = IPINF
  208. MFR = INFELL(13)
  209. LRE = INFELL(9)
  210. LW = INFELL(7)
  211. NDDL = INFELL(15)
  212. c* IELE = INFELL(14)
  213. IPPORE = 0
  214. IPMINT = INFELL(11)
  215. SEGSUP,INFO
  216.  
  217. C-- Recherche des inconnues primales et duales (DEPL-FORC)
  218. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,ndum)
  219. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,ndum)
  220.  
  221. IF (NDEPL.EQ.0 .OR. NFORC.EQ.0 .OR. NDEPL.NE.NFORC) THEN
  222. CALL ERREUR(5)
  223. GOTO 1199
  224. ENDIF
  225.  
  226. C-- Remplissage du segment DESCRipteur
  227. NLIGRP = LRE
  228. NLIGRD = LRE
  229. SEGINI,DESCR
  230.  
  231. NCOMP = NDEPL
  232. NBNNS = NBNOE2
  233. IDDL=1
  234. DO 1004 INOEUD=1,NBNNS
  235. DO 1005 ICOMP=1,NCOMP
  236. NOMID = MODEPL
  237. LISINC(IDDL)=LESOBL(ICOMP)
  238. NOMID = MOFORC
  239. LISDUA(IDDL)=LESOBL(ICOMP)
  240. NOELEP(IDDL)=INOEUD
  241. NOELED(IDDL)=INOEUD
  242. IDDL=IDDL+1
  243. 1005 CONTINUE
  244. 1004 CONTINUE
  245.  
  246. IDESCR = DESCR
  247.  
  248. C-- Recuperation des noms de composantes MATERIAU
  249. nbrobl = 0
  250. nbrfac = 0
  251. nomid = 0
  252. notype = 0
  253.  
  254. C rho, E, nu pour les massifs
  255. IF (MFR.EQ.1) THEN
  256. nbrobl = 3
  257. SEGINI,nomid
  258. lesobl(1) = 'RHO '
  259. lesobl(2) = 'YOUN'
  260. lesobl(3) = 'NU '
  261.  
  262. nbtype = 1
  263. SEGINI,notype
  264. type(1) = 'REAL*8'
  265. C
  266. C rho, cson, rhoref, cref, rlcar pour les liquides
  267. ELSE IF (MFR.EQ.11.OR.MFR.EQ.41) THEN
  268. nbrobl = 5
  269. SEGINI,nomid
  270. lesobl(1) = 'RHO '
  271. lesobl(2) = 'CSON'
  272. lesobl(3) = 'RORF'
  273. lesobl(4) = 'CREF'
  274. lesobl(5) = 'LCAR'
  275.  
  276. nbtype = 1
  277. SEGINI,notype
  278. type(1) = 'REAL*8'
  279. ENDIF
  280.  
  281. MOMATR = nomid
  282. MOTYPM = notype
  283. NMATR = nbrobl
  284. NMATF = nbrfac
  285. NMATT = NMATR+NMATF
  286.  
  287. C--- Verification du support des composantes recherchées
  288. IF (MOMATR.NE.0) THEN
  289. CALL QUESUQ(IMODEL,IPCHE1,3,0,MOMATR,IPLAZ,ISUPM,iret)
  290. IF (ISUPM.GT.1) GOTO 1199
  291. ENDIF
  292. C
  293. C-- Recuperation des noms de composantes CARACTERISTIQUES
  294. nbrobl = 0
  295. nbrfac = 0
  296. nomid = 0
  297. notype = 0
  298.  
  299. C Epaisseur du massif en contraintes planes
  300. IF (MFR.EQ.1 .AND. IFOUR.EQ.-2) THEN
  301. nbrfac = 1
  302. SEGINI,nomid
  303. lesfac(1) = 'DIM3'
  304. nbtype = 1
  305. SEGINI,notype
  306. type(1) = 'REAL*8'
  307. ENDIF
  308.  
  309. MOCARA = nomid
  310. MOTYPC = notype
  311. NCARA = nbrobl
  312. NCARF = nbrfac
  313. NCARR = NCARA+NCARF
  314.  
  315. C--- Verification du support des composantes recherchées
  316. IF (MOCARA.NE.0) THEN
  317. CALL QUESUQ(IMODEL,IPCHE1,3,0,MOCARA,IPLAZ,ISUPC,iret)
  318. IF (ISUPC.GT.1) GOTO 1199
  319. ENDIF
  320.  
  321. C-- Segment d'integration MINTE
  322. MINTE = IPMINT
  323. SEGACT,MINTE
  324. NBPGAU = POIGAU(/1)
  325.  
  326. C- Partionnement si necessaire de la matrice d'amortissement
  327. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  328. LTRK = oooval(1,4)
  329. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  330. * Ajout a la taille en mots de la matrice des infos du segment
  331. LSEG = LRE*LRE*NBELE2 + 16
  332. NBLPRT = (LSEG-1)/LTRK + 1
  333. NBLMAX = (NBELE2-1)/NBLPRT + 1
  334. NBLPRT = (NBELE2-1)/NBLMAX + 1
  335. c* write(ioimp,*) ' frvisq : nblprt nblmax = ',nblprt,nblmax,nbele2
  336. C*OF : Pour l'instant pas de partition pour FRVISQ
  337. NBLPRT = 1
  338.  
  339. C-- Ajout de la matrice d'AMORTISSEMENT a la matrice globale
  340. NRIGE0 = IRIGEL(/2)
  341. NRIGEL = NRIGE0 + NBLPRT
  342. SEGADJ,MRIGID
  343.  
  344. descr = IDESCR
  345. meleme = IPOGEO
  346. nbnn = NBNOE2
  347. nbelem = NBELE2
  348. nbsous = 0
  349. nbref = 0
  350.  
  351. DO 120 irige = 1, NBLPRT
  352.  
  353. C-- Mettre ici la partition du maillage IPOGEO
  354. ipmail = meleme
  355. ipdesc = descr
  356.  
  357. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  358. NELRIG = nbelem
  359. SEGINI,xmatri
  360. ipmatr = xmatri
  361.  
  362. C- Recuperation des valeurs des proprietes materiau et geometriques
  363. c* Note : les proprietes sont les valeurs au support des EF massifs
  364. c* et non celles au niveau de l'enveloppe surfacique !
  365. c* Cela ne marche que si les proprietes sont constantes. Dans
  366. c* les autres cas, le resultat est... Pour eviter cela, on met
  367. c* un test sur la constance du champ !
  368. ivamat = 0
  369. ivacar = 0
  370. IF (MOMATR.NE.0) THEN
  371. CALL KOMCHA(IPCHE1,IPT1,CONM,MOMATR,MOTYPM,1,
  372. c* CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,
  373. & INFOS,3, ivamat)
  374. IF (IERR.NE.0) GOTO 1199
  375. mptval = ivamat
  376. do i = 1, NMATT
  377. if (ival(i).ne.0) then
  378. melval = IVAL(i)
  379. if (velche(/1).ne.1 .and. velche(/2).ne.1) then
  380. write(ioimp,*) 'Champ MATERIAU non constant'
  381. call erreur(21)
  382. goto 1199
  383. endif
  384. endif
  385. enddo
  386. IF (ISUPM.EQ.1) THEN
  387. CALL VALCHE(ivamat,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  388. IF (IERR.NE.0) THEN
  389. ISUPM = 0
  390. GOTO 1199
  391. ENDIF
  392. ENDIF
  393. ENDIF
  394. IF (MOCARA.NE.0) THEN
  395. CALL KOMCHA(IPCHE1,IPT1,CONM,MOCARA,MOTYPC,1,
  396. c* CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,
  397. & INFOS,3, ivacar)
  398. IF (IERR.NE.0) GOTO 1199
  399. mptval = ivacar
  400. do i = 1, NCARR
  401. if (ival(i).ne.0) then
  402. melval = IVAL(i)
  403. if (velche(/1).ne.1 .and. velche(/2).ne.1) then
  404. write(ioimp,*) 'Champ MATERIAU non constant'
  405. call erreur(21)
  406. goto 1199
  407. endif
  408. endif
  409. enddo
  410. IF (ISUPC.EQ.1) THEN
  411. CALL VALCHE(ivacar,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  412. IF (IERR.NE.0)THEN
  413. ISUPC = 0
  414. GOTO 1199
  415. ENDIF
  416. ENDIF
  417. ENDIF
  418.  
  419. C distinction des cas 2D et 3D
  420. C______________________________________________________________________C
  421. C C
  422. C CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS C
  423. C FACES ASSOCIEES SEG2 OU SEG3 C
  424. C______________________________________________________________________C
  425. C C
  426. IF (MELE.EQ.2.OR.MELE.EQ.3) THEN
  427. C
  428. CALL FROA2D(ipmail,ipmatr,IPMINT,ivamat,ivacar,
  429. 1 MELE,MFR,LRE,NDDL)
  430. C
  431. C______________________________________________________________________C
  432. C C
  433. C CAS DES ELEMENTS LIQUIDES 2D OU 3D C
  434. C FACES ASSOCIEES LSE2, LTR3 OU LQU4 C
  435. C______________________________________________________________________C
  436. C C
  437. C
  438. ELSE IF(MELE.EQ.97.OR.MELE.EQ.35.OR.MELE.EQ.36) THEN
  439. C
  440. CALL LFROA(ipmail,ipmatr,IPMINT,ivamat,ivacar,
  441. 1 MELE,MFR,LRE,NDDL)
  442. C
  443. C______________________________________________________________________C
  444. C C
  445. C CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS C
  446. C FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8 C
  447. C______________________________________________________________________C
  448. C
  449. ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.
  450. 1 OR.MELE.EQ.34)THEN
  451. C
  452. CALL FROA3D(ipmail,ipmatr,IPMINT,ivamat,ivacar,
  453. 1 MELE,MFR,LRE,NDDL)
  454. C
  455. C erreur, l'élément n'est pas encore implémenté
  456. C
  457. ELSE
  458. C
  459. MOTERR(1:4)=NOMTP(MELE)
  460. MOTERR(5:12)='FRVISQ'
  461. CALL ERREUR (86)
  462. ENDIF
  463. C
  464. IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN
  465. CALL DTMVAL(ivamat,3)
  466. ELSE
  467. CALL DTMVAL(ivamat,1)
  468. ENDIF
  469. IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN
  470. CALL DTMVAL(ivacar,3)
  471. ELSE
  472. CALL DTMVAL(ivacar,1)
  473. ENDIF
  474.  
  475. xmatri = ipmatr
  476. IF (NBLPRT.GT.1) THEN
  477. meleme = ipmail
  478. ENDIF
  479.  
  480. C- Sortie prematuree en cas d'erreur
  481. IF (IERR.NE.0) GOTO 1199
  482.  
  483. C- Stockage de la matrice
  484. jrige = NRIGE0 + irige
  485. COERIG(jrige) = 1.
  486. IRIGEL(1,jrige) = ipmail
  487. IRIGEL(2,jrige) = 0
  488. IRIGEL(3,jrige) = ipdesc
  489. IRIGEL(4,jrige) = ipmatr
  490. IRIGEL(5,jrige) = NIFOUR
  491. IRIGEL(6,jrige) = 0
  492. IRIGEL(7,jrige) = 0
  493. * matrice non symetrique (forces sur pi seulement
  494. * qui dependent de p)
  495. IF (MFR.EQ.11.OR.MFR.EQ.41) THEN
  496. IRIGEL(7,jrige) = 2
  497. xmatri.symre=2
  498. ENDIF
  499. SEGDES,xmatri
  500. IRIGEL(8,jrige) = 0
  501.  
  502. 120 CONTINUE
  503. C- Fin de la boucle de partition maillage/rigidite
  504.  
  505. 1199 CONTINUE
  506. IF (MOMATR.NE.0) THEN
  507. nomid = MOMATR
  508. SEGSUP,nomid
  509. notype = MOTYPM
  510. SEGSUP,notype
  511. ENDIF
  512. IF (MOCARA.NE.0) THEN
  513. nomid = MOCARA
  514. SEGSUP,nomid
  515. notype = MOTYPC
  516. SEGSUP,notype
  517. ENDIF
  518. C
  519.  
  520. C- Sortie prematuree en cas d'erreur
  521. IF (IERR.NE.0) GOTO 1098
  522.  
  523. 110 CONTINUE
  524. C- Fin de la boucle sur (les sous-zones de) l'enveloppe
  525. C
  526. 1098 CONTINUE
  527. 1099 CONTINUE
  528. C- Sortie prematuree en cas d'erreur
  529. IF (IERR.NE.0) GOTO 999
  530. C
  531. 100 CONTINUE
  532. C- Fin de la boucle sur les modeles elementaires
  533. C
  534. NRIGE0 = IRIGEL(/2)
  535. IF (NRIGE0.EQ.0) THEN
  536. CALL ERREUR(902)
  537. ENDIF
  538.  
  539. 999 CONTINUE
  540. IF (IERR.EQ.0) THEN
  541. IPRIG = MRIGID
  542. SEGDES,MRIGID
  543. ELSE
  544. IPRIG = 0
  545. SEGSUP,MRIGID
  546. ENDIF
  547.  
  548. END
  549.  
  550.  
  551.  

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