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

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