Télécharger frvisq.eso

Retour à la liste

Numérotation des lignes :

  1. C FRVISQ SOURCE PV 17/09/29 21:15:12 9578
  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. SEGDES,DESCR
  247. IDESCR = DESCR
  248.  
  249. C-- Recuperation des noms de composantes MATERIAU
  250. nbrobl = 0
  251. nbrfac = 0
  252. nomid = 0
  253. notype = 0
  254.  
  255. C rho, E, nu pour les massifs
  256. IF (MFR.EQ.1) THEN
  257. nbrobl = 3
  258. SEGINI,nomid
  259. lesobl(1) = 'RHO '
  260. lesobl(2) = 'YOUN'
  261. lesobl(3) = 'NU '
  262.  
  263. nbtype = 1
  264. SEGINI,notype
  265. type(1) = 'REAL*8'
  266. C
  267. C rho, cson, rhoref, cref, rlcar pour les liquides
  268. ELSE IF (MFR.EQ.11.OR.MFR.EQ.41) THEN
  269. nbrobl = 5
  270. SEGINI,nomid
  271. lesobl(1) = 'RHO '
  272. lesobl(2) = 'CSON'
  273. lesobl(3) = 'RORF'
  274. lesobl(4) = 'CREF'
  275. lesobl(5) = 'LCAR'
  276.  
  277. nbtype = 1
  278. SEGINI,notype
  279. type(1) = 'REAL*8'
  280. ENDIF
  281.  
  282. MOMATR = nomid
  283. MOTYPM = notype
  284. NMATR = nbrobl
  285. NMATF = nbrfac
  286. NMATT = NMATR+NMATF
  287.  
  288. C--- Verification du support des composantes recherchées
  289. IF (MOMATR.NE.0) THEN
  290. CALL QUESUQ(IMODEL,IPCHE1,3,0,MOMATR,IPLAZ,ISUPM,iret)
  291. IF (ISUPM.GT.1) GOTO 1199
  292. ENDIF
  293. C
  294. C-- Recuperation des noms de composantes CARACTERISTIQUES
  295. nbrobl = 0
  296. nbrfac = 0
  297. nomid = 0
  298. notype = 0
  299.  
  300. C Epaisseur du massif en contraintes planes
  301. IF (MFR.EQ.1 .AND. IFOUR.EQ.-2) THEN
  302. nbrfac = 1
  303. SEGINI,nomid
  304. lesfac(1) = 'DIM3'
  305. nbtype = 1
  306. SEGINI,notype
  307. type(1) = 'REAL*8'
  308. ENDIF
  309.  
  310. MOCARA = nomid
  311. MOTYPC = notype
  312. NCARA = nbrobl
  313. NCARF = nbrfac
  314. NCARR = NCARA+NCARF
  315.  
  316. C--- Verification du support des composantes recherchées
  317. IF (MOCARA.NE.0) THEN
  318. CALL QUESUQ(IMODEL,IPCHE1,3,0,MOCARA,IPLAZ,ISUPC,iret)
  319. IF (ISUPC.GT.1) GOTO 1199
  320. ENDIF
  321.  
  322. C-- Segment d'integration MINTE
  323. MINTE = IPMINT
  324. SEGACT,MINTE
  325. NBPGAU = POIGAU(/1)
  326.  
  327. C- Partionnement si necessaire de la matrice d'amortissement
  328. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  329. LTRK = oooval(1,4)
  330. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  331. * Ajout a la taille en mots de la matrice des infos du segment
  332. LSEG = LRE*LRE*NBELE2 + 16
  333. NBLPRT = (LSEG-1)/LTRK + 1
  334. NBLMAX = (NBELE2-1)/NBLPRT + 1
  335. NBLPRT = (NBELE2-1)/NBLMAX + 1
  336. c* write(ioimp,*) ' frvisq : nblprt nblmax = ',nblprt,nblmax,nbele2
  337. C*OF : Pour l'instant pas de partition pour FRVISQ
  338. NBLPRT = 1
  339.  
  340. C-- Ajout de la matrice d'AMORTISSEMENT a la matrice globale
  341. NRIGE0 = IRIGEL(/2)
  342. NRIGEL = NRIGE0 + NBLPRT
  343. SEGADJ,MRIGID
  344.  
  345. descr = IDESCR
  346. meleme = IPOGEO
  347. nbnn = NBNOE2
  348. nbelem = NBELE2
  349. nbsous = 0
  350. nbref = 0
  351.  
  352. DO 120 irige = 1, NBLPRT
  353.  
  354. C-- Mettre ici la partition du maillage IPOGEO
  355. ipmail = meleme
  356. ipdesc = descr
  357.  
  358. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  359. NELRIG = nbelem
  360. SEGINI,xmatri
  361. ipmatr = xmatri
  362.  
  363. C- Recuperation des valeurs des proprietes materiau et geometriques
  364. c* Note : les proprietes sont les valeurs au support des EF massifs
  365. c* et non celles au niveau de l'enveloppe surfacique !
  366. c* Cela ne marche que si les proprietes sont constantes. Dans
  367. c* les autres cas, le resultat est... Pour eviter cela, on met
  368. c* un test sur la constance du champ !
  369. ivamat = 0
  370. ivacar = 0
  371. IF (MOMATR.NE.0) THEN
  372. CALL KOMCHA(IPCHE1,IPT1,CONM,MOMATR,MOTYPM,1,
  373. c* CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,
  374. & INFOS,3, ivamat)
  375. IF (IERR.NE.0) GOTO 1199
  376. mptval = ivamat
  377. do i = 1, NMATT
  378. if (ival(i).ne.0) then
  379. melval = IVAL(i)
  380. if (velche(/1).ne.1 .and. velche(/2).ne.1) then
  381. write(ioimp,*) 'Champ MATERIAU non constant'
  382. call erreur(21)
  383. goto 1199
  384. endif
  385. endif
  386. enddo
  387. IF (ISUPM.EQ.1) THEN
  388. CALL VALCHE(ivamat,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  389. IF (IERR.NE.0) THEN
  390. ISUPM = 0
  391. GOTO 1199
  392. ENDIF
  393. ENDIF
  394. ENDIF
  395. IF (MOCARA.NE.0) THEN
  396. CALL KOMCHA(IPCHE1,IPT1,CONM,MOCARA,MOTYPC,1,
  397. c* CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,
  398. & INFOS,3, ivacar)
  399. IF (IERR.NE.0) GOTO 1199
  400. mptval = ivacar
  401. do i = 1, NCARR
  402. if (ival(i).ne.0) then
  403. melval = IVAL(i)
  404. if (velche(/1).ne.1 .and. velche(/2).ne.1) then
  405. write(ioimp,*) 'Champ MATERIAU non constant'
  406. call erreur(21)
  407. goto 1199
  408. endif
  409. endif
  410. enddo
  411. IF (ISUPC.EQ.1) THEN
  412. CALL VALCHE(ivacar,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  413. IF (IERR.NE.0)THEN
  414. ISUPC = 0
  415. GOTO 1199
  416. ENDIF
  417. ENDIF
  418. ENDIF
  419.  
  420. C distinction des cas 2D et 3D
  421. C______________________________________________________________________C
  422. C C
  423. C CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS C
  424. C FACES ASSOCIEES SEG2 OU SEG3 C
  425. C______________________________________________________________________C
  426. C C
  427. IF (MELE.EQ.2.OR.MELE.EQ.3) THEN
  428. C
  429. CALL FROA2D(ipmail,ipmatr,IPMINT,ivamat,ivacar,
  430. 1 MELE,MFR,LRE,NDDL)
  431. C
  432. C______________________________________________________________________C
  433. C C
  434. C CAS DES ELEMENTS LIQUIDES 2D OU 3D C
  435. C FACES ASSOCIEES LSE2, LTR3 OU LQU4 C
  436. C______________________________________________________________________C
  437. C C
  438. C
  439. ELSE IF(MELE.EQ.97.OR.MELE.EQ.35.OR.MELE.EQ.36) THEN
  440. C
  441. CALL LFROA(ipmail,ipmatr,IPMINT,ivamat,ivacar,
  442. 1 MELE,MFR,LRE,NDDL)
  443. C
  444. C______________________________________________________________________C
  445. C C
  446. C CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS C
  447. C FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8 C
  448. C______________________________________________________________________C
  449. C
  450. ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.
  451. 1 OR.MELE.EQ.34)THEN
  452. C
  453. CALL FROA3D(ipmail,ipmatr,IPMINT,ivamat,ivacar,
  454. 1 MELE,MFR,LRE,NDDL)
  455. C
  456. C erreur, l'élément n'est pas encore implémenté
  457. C
  458. ELSE
  459. C
  460. MOTERR(1:4)=NOMTP(MELE)
  461. MOTERR(5:12)='FRVISQ'
  462. CALL ERREUR (86)
  463. ENDIF
  464. C
  465. IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN
  466. CALL DTMVAL(ivamat,3)
  467. ELSE
  468. CALL DTMVAL(ivamat,1)
  469. ENDIF
  470. IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN
  471. CALL DTMVAL(ivacar,3)
  472. ELSE
  473. CALL DTMVAL(ivacar,1)
  474. ENDIF
  475.  
  476. xmatri = ipmatr
  477. IF (NBLPRT.GT.1) THEN
  478. meleme = ipmail
  479. SEGDES,meleme
  480. ENDIF
  481.  
  482. C- Sortie prematuree en cas d'erreur
  483. IF (IERR.NE.0) GOTO 1199
  484.  
  485. C- Stockage de la matrice
  486. jrige = NRIGE0 + irige
  487. COERIG(jrige) = 1.
  488. IRIGEL(1,jrige) = ipmail
  489. IRIGEL(2,jrige) = 0
  490. IRIGEL(3,jrige) = ipdesc
  491. IRIGEL(4,jrige) = ipmatr
  492. IRIGEL(5,jrige) = NIFOUR
  493. IRIGEL(6,jrige) = 0
  494. IRIGEL(7,jrige) = 0
  495. * matrice non symetrique (forces sur pi seulement
  496. * qui dependent de p)
  497. IF (MFR.EQ.11.OR.MFR.EQ.41) THEN
  498. IRIGEL(7,jrige) = 2
  499. xmatri.symre=2
  500. ENDIF
  501. SEGDES,xmatri
  502. IRIGEL(8,jrige) = 0
  503.  
  504. 120 CONTINUE
  505. C- Fin de la boucle de partition maillage/rigidite
  506.  
  507. SEGDES,MINTE
  508. 1199 CONTINUE
  509. IF (MOMATR.NE.0) THEN
  510. nomid = MOMATR
  511. SEGSUP,nomid
  512. notype = MOTYPM
  513. SEGSUP,notype
  514. ENDIF
  515. IF (MOCARA.NE.0) THEN
  516. nomid = MOCARA
  517. SEGSUP,nomid
  518. notype = MOTYPC
  519. SEGSUP,notype
  520. ENDIF
  521. C
  522. IF (NBSOU3.NE.0) SEGDES,IPT2
  523.  
  524. C- Sortie prematuree en cas d'erreur
  525. IF (IERR.NE.0) GOTO 1098
  526.  
  527. 110 CONTINUE
  528. C- Fin de la boucle sur (les sous-zones de) l'enveloppe
  529. C
  530. 1098 CONTINUE
  531. SEGDES,IPT3
  532. 1099 CONTINUE
  533. SEGDES,IMODEL
  534. C- Sortie prematuree en cas d'erreur
  535. IF (IERR.NE.0) GOTO 999
  536. C
  537. 100 CONTINUE
  538. C- Fin de la boucle sur les modeles elementaires
  539. C
  540. NRIGE0 = IRIGEL(/2)
  541. IF (NRIGE0.EQ.0) THEN
  542. CALL ERREUR(902)
  543. ENDIF
  544.  
  545. 999 CONTINUE
  546. IF (IERR.EQ.0) THEN
  547. IPRIG = MRIGID
  548. SEGDES,MRIGID
  549. ELSE
  550. IPRIG = 0
  551. SEGSUP,MRIGID
  552. ENDIF
  553. SEGDES,MMODEL
  554.  
  555. RETURN
  556. END
  557.  
  558.  
  559.  
  560.  
  561.  
  562.  
  563.  

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