Télécharger intgca.eso

Retour à la liste

Numérotation des lignes :

  1. C INTGCA SOURCE FANDEUR 18/03/01 21:15:05 9764
  2.  
  3. C=======================================================================
  4. C= I N T G C A =
  5. C= ----------- =
  6. C= =
  7. C= Fonction : =
  8. C= ---------- =
  9. C= Integration d'un champ scalaire sur un maillage ou par element. =
  10. C= Sous-programme appele par INTGRA (intgra.eso). =
  11. C= =
  12. C= Parametres : (E)=Entree (S)=Sortie =
  13. C= ------------ =
  14. C= IPMODL (E) Pointeur sur le segment MMODEL =
  15. C= IPCHE1 (E) Pointeur sur segment MCHELM a une seule composante =
  16. C= IPCHE2 (E) Pointeur sur le segment MCHELM de CARACTERISTIQUES =
  17. C= KOPELE (E) =0 si on ne veut pas un MCHAML resultat =
  18. C= IPINT (S) Pointeur sur le segment MCHELM resultat =
  19. C= XRET (S) Flottant resultant de l'integration si demande =
  20. C= IRET (S) Entier valant 1 en cas de succes, 0 sinon (et un =
  21. C= message d'erreur est imprime dans ce cas) =
  22. C= =
  23. C= Remarque : Autrefois, le champ resultat avait le meme support que =
  24. C= ---------- le champ IPCHE1,soit IPINT/MCHEL1.INFCHE(iSou,6)). =
  25. C= Maintenant, le champ resultat IPINT est donne au centre =
  26. C= de gravite quelque soit le support du champ integre, =
  27. C= soit IPINT.INFCHE(iSou,6)=2 . =
  28. C=======================================================================
  29.  
  30. SUBROUTINE INTGCA (IPMODL,IPCHE1,IPCHE2,KOPELE,IRET,XRET,IPINT)
  31.  
  32. IMPLICIT INTEGER(I-N)
  33. IMPLICIT REAL*8 (A-H,O-Z)
  34.  
  35. -INC CCREEL
  36. -INC CCOPTIO
  37. -INC CCHAMP
  38. -INC SMMODEL
  39. -INC SMCHAML
  40. -INC SMELEME
  41. -INC SMCOORD
  42. -INC SMINTE
  43.  
  44. SEGMENT MWRK1
  45. REAL*8 SHP(6,NBNO),XEL(3,NBBB),BPSS(3,3),XE(3,NBBB)
  46. ENDSEGMENT
  47.  
  48. SEGMENT MWRK2
  49. REAL*8 TXR(3,3,NBBB),XJ(3,3)
  50. ENDSEGMENT
  51.  
  52. SEGMENT MWRK3
  53. REAL*8 WORK(LW)
  54. ENDSEGMENT
  55.  
  56. SEGMENT INFO
  57. INTEGER INFELL(JG)
  58. ENDSEGMENT
  59.  
  60. SEGMENT NOTYPE
  61. CHARACTER*16 TYPE(NBTYPE)
  62. ENDSEGMENT
  63.  
  64. SEGMENT MPTVAL
  65. INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  66. CHARACTER*16 TYVAL(NCOSOU)
  67. ENDSEGMENT
  68.  
  69. PARAMETER (NINF=3)
  70. INTEGER INFOS(NINF)
  71. CHARACTER*(NCONCH) CONM
  72. CHARACTER*8 CHARIN
  73. LOGICAL LOGCOQ
  74.  
  75. C= Quelques constantes (2.Pi et 4.Pi)
  76. PARAMETER (X2Pi=6.283185307179586476925286766559D0)
  77. PARAMETER (X4Pi=12.566370614359172953850573533118D0)
  78.  
  79. IRET=0
  80.  
  81. C 1 - VERIFICATIONS DES DONNEES DE L'OPERATEUR
  82. C Verification du lieu support du MCHAML a integrer
  83. C =======================================================
  84. MMODEL=IPMODL
  85. SEGACT,MMODEL
  86. NSOUS=KMODEL(/1)
  87.  
  88. * Cas du MMODEL VIDE...
  89. IF (NSOUS .EQ. 0) THEN
  90. IRET = 1
  91. XRET =REAL(0.D0)
  92. IPINT=0
  93. IF (KOPELE .NE. 0) THEN
  94. L1=8
  95. N1=0
  96. N3=6
  97. SEGINI,MCHELM
  98. TITCHE='SCALAIRE'
  99. IFOCHE=IFOUR
  100. IPINT=MCHELM
  101. SEGDES,MCHELM
  102. ENDIF
  103. SEGDES,MMODEL
  104. RETURN
  105. ENDIF
  106.  
  107. * Autre Cas
  108. IMODEL=KMODEL(1)
  109. SEGACT,IMODEL
  110. ITHER = 0
  111. CALL PLACE(FORMOD,FORMOD(/2),ITHER,'THERMIQUE')
  112. IDIFF = 0
  113. CALL PLACE(FORMOD,FORMOD(/2),IDIFF,'DIFFUSION')
  114. IF (ITHER.EQ.0.AND.IDIFF.EQ.0) THEN
  115. ** IS=3
  116. * On determine le support du champ d'entree
  117. IS=0
  118. ISup1=0
  119. iOK=0
  120. CALL QUESUP(IPMODL,IPCHE1,IS,0,ISup1,iOK)
  121. IF (iOK.EQ.9999) call erreur(609)
  122. if (ierr.ne.0) return
  123. IS=iOK
  124. * Dans le cas d'un champ constant, au centre de gravite ou aux noeuds,
  125. * on utilise les points de la rigidite.
  126. IF (IS.EQ.1 .OR. IS.EQ.2) IS=3
  127. ELSE
  128. IS=6
  129. ENDIF
  130. SEGDES,IMODEL,MMODEL
  131. ISup1=0
  132. iOK=0
  133. CALL QUESUP(IPMODL,IPCHE1,IS,0,ISup1,iOK)
  134. IF (ISup1.GT.1) call erreur(609)
  135. if (ierr.ne.0) return
  136.  
  137. C 2 - QUELQUES INITIALISATIONS
  138. C ==============================
  139. C 2.1 - Activation du MMODEL
  140. C =====
  141. MMODEL=IPMODL
  142. SEGACT,MMODEL
  143. C =====
  144. C 2.2 - Initialisation du MCHELM resultat si demande
  145. C =====
  146. XRET =REAL(0.D0)
  147. IPINT=0
  148. IF (KOPELE .NE. 0) THEN
  149. L1=8
  150. N1=NSOUS
  151. N3=6
  152. SEGINI,MCHELM
  153. TITCHE='SCALAIRE'
  154. IFOCHE=IFOUR
  155. IPINT=MCHELM
  156. ENDIF
  157. C =====
  158. C 2.3 - Recuperation du nom de la composante de IPCHE1
  159. C Traitement effectue ici car identique sur tout le modele
  160. C =====
  161. MCHEL1=IPCHE1
  162. SEGACT,MCHEL1
  163.  
  164. C CB215821 : A la recherche des MCHELM VIDES issus de REDUAF
  165. NZ=MCHEL1.ICHAML(/1)
  166. IF (NZ .EQ. 0) THEN
  167. IF(KOPELE .NE. 0) THEN
  168. N2 =1
  169. N1PTEL=1
  170. N1EL =1
  171. N2PTEL=0
  172. N2EL =0
  173. DO iSou=1,NSOUS
  174. IMODEL=KMODEL(iSou)
  175. SEGACT,IMODEL
  176. SEGINI,MCHAML
  177. ICHAML(iSou)=MCHAML
  178. IMACHE(iSou)=IMAMOD
  179. CONCHE(iSou)=CONMOD
  180. TYPCHE(iSou)='REAL*8'
  181. NOMCHE(iSou)='SCAL'
  182. INFCHE(iSou,1)=0
  183. INFCHE(iSou,2)=0
  184. INFCHE(iSou,3)=NIFOUR
  185. INFCHE(iSou,4)=MCHEL1.INFCHE(iSou,4)
  186. INFCHE(iSou,5)=0
  187. INFCHE(iSou,6)=2
  188. SEGINI,MELVAL
  189. IELVAL(1 )=MELVAL
  190. SEGDES,MELVAL,MCHAML,IMODEL
  191. ENDDO
  192. ENDIF
  193. SEGDES,MCHEL1,MMODEL
  194. RETURN
  195. ENDIF
  196.  
  197. MCHAML=MCHEL1.ICHAML(1)
  198. SEGACT,MCHAML
  199. NBROBL=1
  200. NBRFAC=0
  201. SEGINI,NOMID
  202. LESOBL(1)=NOMCHE(1)
  203. SEGDES,MCHAML,MCHEL1
  204. NBTYPE=1
  205. SEGINI,NOTYPE
  206. TYPE(1)='REAL*8'
  207. MOCOMP=NOMID
  208. MOTYCO=NOTYPE
  209.  
  210. C 3 - BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE (iSou)
  211. C ========================================================
  212. isouss=0
  213. DO 2000 iSou=1,NSOUS
  214. C =====
  215. C 3.1 - Quelques initialisations
  216. C =====
  217. IVACOM=0
  218. MOCARA=0
  219. IVACAR=0
  220. MCHAML=0
  221. IPMEL1=0
  222. IPMEL2=0
  223. MWRK3 =0
  224. C =====
  225. C 3.2 - Activation du sous-modele (iSou)
  226. C =====
  227. IMODEL=KMODEL(iSou)
  228. SEGACT,IMODEL
  229. CONM=CONMOD
  230. MELE=NEFMOD
  231. if( (mele.eq.22).or.(mele.eq.259)) then
  232. segdes imodel
  233. go to 2000
  234. endif
  235. isouss=isouss+1
  236. C =====
  237. C 3.3 - Recuperation du maillage associe au sous-modele (iSou)
  238. C Traitement particulier dans le cas d'une formulation DARCY
  239. C =====
  240. IPMAIL=IMAMOD
  241. CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY')
  242. IF (IDARC.NE.0) THEN
  243. CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  244. CHARIN='MAILLAGE'
  245. CALL LEKTAB(IPTABL,CHARIN,IOBRE)
  246. IF (IERR.NE.0) GOTO 250
  247. IF (NSOUS.GT.1)THEN
  248. IPT1=IOBRE
  249. SEGACT,IPT1
  250. IPMAIL=IPT1.LISOUS(iSou)
  251. SEGDES,IPT1
  252. ELSE
  253. IPMAIL=IOBRE
  254. ENDIF
  255. ENDIF
  256. C =====
  257. C 3.4 - Determination ...
  258. C =====
  259. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,iOK)
  260. IF (iOK.EQ.0) GOTO 250
  261. iOK=0
  262. C =====
  263. C 3.5 - Recuperation d'informations sur l'element fini du sous-modele
  264. C ERREUR si la formulation n'est pas disponible
  265. C ???? ERREUR si l'element est une element JOINT (non implante)
  266. C =====
  267. LOGCOQ=.FALSE.
  268. IF (ITHER.EQ.0 .AND. IDIFF.EQ.0) THEN
  269. if(infmod(/1).lt.4) then
  270. CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  271. IF (IERR.NE.0) GOTO 240
  272. INFO=IPINF
  273. mincdg=INFELL(11)
  274. SEGSUP,INFO
  275. else
  276. mincdg=infmod(4)
  277. endif
  278. C* if(infmod(/1).lt.5) then
  279. C* CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  280. if(infmod(/1).lt.IS+2) then
  281. CALL ELQUOI(MELE,0,IS,IPINF,IMODEL)
  282. IF (IERR.NE.0) GOTO 240
  283. INFO=IPINF
  284. IPMINT=INFELL(11)
  285. MINTE1=INFELL(12)
  286. MFR=INFELL(13)
  287. LW=INFELL(7)
  288. NLG=INFELL(14)
  289. SEGSUP,INFO
  290. else
  291. C* IPMINT=infmod(5)
  292. IPMINT=infmod(IS+2)
  293. MINTE1=INFMOD(8)
  294. MFR=INFELE(13)
  295. LW=INFELE(7)
  296. IPORE=INFELE(8)
  297. NLG=INFELE(14)
  298. endif
  299. IF (MFR.EQ.5) LOGCOQ=.TRUE.
  300. ELSE
  301. mincdg=0
  302. LW=100
  303. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  304. IF (MELE.EQ.41.OR.MELE.EQ.56.OR.MELE.EQ.49) THEN
  305. LOGCOQ=.TRUE.
  306. CALL TSHAPE(MELE,'NOEUD',IPMIN1)
  307. MINTE1=IPMIN1
  308. ENDIF
  309. MFR=NUMMFR(MELE)
  310. NLG=NUMGEO(MELE)
  311. ENDIF
  312. * write(6,*) 'MFR,IDIM=',MFR,IDIM
  313. IF (MFR.NE. 1.AND.MFR.NE. 3.AND.MFR.NE. 7.AND.MFR.NE.9.AND.
  314. . MFR.NE.11.AND.MFR.NE.13.AND.MFR.NE.33.AND.MFR.NE.5.AND.
  315. . MFR.NE.31.AND.MFR.NE.35.AND.MFR.NE.63.AND.MFR.NE.71.AND.
  316. & MFR.NE.73.AND.MFR.NE.57.AND.MFR.NE.59.AND.MFR.NE.77.AND.
  317. & MFR.NE.72..AND.MFR.NE.74.AND.MFR.NE.27) THEN
  318. MOTERR(1:8)=NOMFR(MFR)
  319. CALL ERREUR(193)
  320. GOTO 240
  321. ENDIF
  322. IF (MFR.EQ.35.AND.IDIM.NE.2) THEN
  323. IF (MELE.NE.87.AND.MELE.NE.88) THEN
  324. MOTERR(1:4)=NOMTP(MELE)
  325. MOTERR(5:12)='INTG'
  326. CALL ERREUR(86)
  327. GOTO 240
  328. ENDIF
  329. ENDIF
  330. CALL QUEDIM(NLG,JDIM)
  331. MINTE=IPMINT
  332. SEGACT,MINTE
  333. C =====
  334. C 3.6 - Recuperation de la composante a integrer
  335. C Verification de sa presence dans le MCHAML (IPCHE1)
  336. C Appel a KOMCHA : NINFO=0 pour le moment...
  337. C Recuperation du MELVAL associe a ce MCHAML sur IPMAIL
  338. C =====
  339. NINFO=0
  340. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYCO,1,
  341. . INFOS,NINFO,IVACOM)
  342. IF (IERR.NE.0) GOTO 230
  343. MPTVAL=IVACOM
  344. MELVA1=IVAL(1)
  345. SEGACT,MELVA1
  346. NBPTEL=MELVA1.VELCHE(/1)
  347. IPMEL1=MELVA1
  348. IF (ISup1.EQ.1) THEN
  349. CALL VALMEL(IPMEL1,IPMINT,IPMEL2)
  350. C*OF ? SEGSUP,MELVA1
  351. MELVA1=IPMEL2
  352. ENDIF
  353. IPMEL1=MELVA1
  354. C =====
  355. C 3.7 - Recuperation des noms des caracteristiques geometriques
  356. C =====
  357. CHARIN=' '
  358. CALL CARAMK(MFR,IFOUR,MELE,CHARIN,IVECT,MOCARA,NBROBL,NBRFAC,
  359. . NBRTOT,MOTYPE,NBTYPE)
  360. NOMID=MOCARA
  361. NOTYPE=MOTYPE
  362. IF (NBRTOT.NE.0.AND.IPCHE2.NE.0) THEN
  363. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
  364. . IVACAR)
  365. SEGSUP,NOTYPE
  366. IF (IERR.NE.0) GOTO 210
  367. IF (IVECT.EQ.1) THEN
  368. MPTVAL=IVACAR
  369. IF (IVAL(NBRTOT).EQ.0) THEN
  370. IVECT=2
  371. NOMID=MOCARA
  372. SEGACT,NOMID
  373. NBRFAC=NBRFAC+2
  374. SEGADJ,NOMID
  375. MOCARA=NOMID
  376. LESFAC(NBRFAC-2)='VX '
  377. LESFAC(NBRFAC-1)='VY '
  378. LESFAC(NBRFAC) ='VZ '
  379. NBTYPE=1
  380. SEGINI,NOTYPE
  381. MOTYPE=NOTYPE
  382. TYPE(1)='REAL*8'
  383. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
  384. . IVACAR)
  385. SEGSUP,NOTYPE
  386. IF (IERR.NE.0) GOTO 210
  387. ENDIF
  388. ENDIF
  389. ENDIF
  390. NCARA=NBROBL
  391. NCARF=NBRFAC
  392. NCARR=NCARA+NCARF
  393. IF (IVACAR.NE.0) THEN
  394. MPTVAL=IVACAR
  395. DO i=1,IVAL(/1)
  396. IPMELV=IVAL(i)
  397. CALL QUELCH(IPMELV,ICONS)
  398. IF (ICONS.NE.0) THEN
  399. CALL ERREUR(566)
  400. GOTO 210
  401. ENDIF
  402. ENDDO
  403. ENDIF
  404. C =====
  405. C 3.8 - Activation du maillage elementaire MELEME
  406. C =====
  407. MELEME=IPMAIL
  408. SEGACT,MELEME
  409. NBNN=NUM(/1)
  410. NBELEM=NUM(/2)
  411. C =====
  412. C 3.9 - Initialisation du MCHAML resultat (MCHAML) associe au modele
  413. C elementaire iSou (de maillage IPMAIL) SI demande
  414. C Remplissage des donnees associees a MCHAML dans MCHELM (global)
  415. C =====
  416. MCHEL1=IPCHE1
  417. SEGACT,MCHEL1
  418. IF (KOPELE.NE.0) THEN
  419. C= 3.9.1 - Initialisation de MCHAML
  420. N2=1
  421. SEGINI,MCHAML
  422. NOMCHE(N2)='SCAL'
  423. TYPCHE(N2)='REAL*8'
  424. C= 3.9.2 - Remplissage de MCHEML(iSou)
  425. CONCHE(iSouss)=CONM
  426. IMACHE(iSouss)=IPMAIL
  427. ICHAML(iSouss)=MCHAML
  428. INFCHE(iSouss,1)=0
  429. INFCHE(iSouss,2)=0
  430. INFCHE(iSouss,3)=NIFOUR
  431. INFCHE(iSouss,4)=MCHEL1.INFCHE(iSouss,4)
  432. IF (mincdg.NE.0) INFCHE(iSouss,4)=mincdg
  433. INFCHE(iSouss,5)=0
  434. INFCHE(iSouss,6)=2
  435. C= 3.9.3 - Initialisation du MELVAL associe a ce MCHAML
  436. N1PTEL=1
  437. N1EL=NBELEM
  438. N2PTEL=0
  439. N2EL=0
  440. SEGINI,MELVA2
  441. IELVAL(N2)=MELVA2
  442. IPMEL2=MELVA2
  443. ENDIF
  444. C ======
  445. C 3.10 - Recuperation des donnees d'integration
  446. C Traitement particulier dans le cas du COQ4 (si le nombre de
  447. C points de Gauss vaut 5, seuls les 4 premiers sont traites, le
  448. C 5e servant uniquement au cisaillement)
  449. C ======
  450. C* MINTE=IPMINT
  451. C* SEGACT,MINTE <- Deja ACTIF
  452. NBPGAU=POIGAU(/1)
  453. NBBB=NBNN
  454. NBNO=NBNN
  455. IF ((MELE.GE.108.AND.MELE.LE.110).OR.
  456. & (MELE.GE.185.AND.MELE.LE.190)) NBNO=IPORE
  457. IF (MELE.EQ.49) THEN
  458. IF (NBPGAU.EQ.5) NBPGAU=4
  459. IF (NBPTEL.EQ.5) NBPTEL=4
  460. ENDIF
  461. C ======
  462. C 3.11 - Initialisation de quelques segments de travail
  463. C ======
  464. SEGINI,MWRK1
  465. IF (LOGCOQ) THEN
  466. SEGINI,MWRK2
  467. SEGACT,MINTE1
  468. SEGINI,MWRK3
  469. ELSE IF (IPCHE2.NE.0) THEN
  470. SEGINI,MWRK3
  471. ENDIF
  472. C ======
  473. C 3.12 - Boucle sur les elements du sous-modele elementaire
  474. C ======
  475. DO IB=1,NBELEM
  476. C= 3.12.1 - Recuperation des coordonnees des noeuds de l element IB
  477. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  478. C= 3.12.2 - Determination des axes locaux aux noeuds (elements COQUES)
  479. IF (LOGCOQ) THEN
  480. CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
  481. IF (IRR.EQ.0) THEN
  482. CALL ERREUR(515)
  483. GOTO 200
  484. ENDIF
  485. IF (IVACAR.NE.0) THEN
  486. MPTVAL=IVACAR
  487. DO iGau=1,NBPGAU
  488. MELVAL=IVAL(1)
  489. IGMN=MIN(iGau,VELCHE(/1))
  490. IBMN=MIN(IB,VELCHE(/2))
  491. WORK(iGau)=VELCHE(IGMN,IBMN)
  492. IF (IVAL(2).NE.0) THEN
  493. MELVAL=IVAL(2)
  494. IGMN=MIN(iGau,VELCHE(/1))
  495. IBMN=MIN(IB,VELCHE(/2))
  496. WORK(20+iGau)=VELCHE(IGMN,IBMN)
  497. ELSE
  498. WORK(20+iGau)=0.
  499. ENDIF
  500. ENDDO
  501. ELSE
  502. C* Si pas de caracteristiques, on met les epaisseurs a 1 (et non a 0)
  503. DO iGau=1,NBPGAU
  504. WORK(iGau)=1.
  505. ENDDO
  506. ENDIF
  507. ENDIF
  508. C= 3.12.3 - Boucle sur les points d'integration
  509. ESTEL=XZero
  510. DO iGau=1,NBPGAU
  511. IBMN=MIN(IB,MELVA1.VELCHE(/2))
  512. IGMN=MIN(iGau,MELVA1.VELCHE(/1))
  513. FACSCA=MELVA1.VELCHE(IGMN,IBMN)
  514. C= 3.12.3.1 - Elements COQUES
  515. IF (LOGCOQ) THEN
  516. E3=DZEGAU(iGau)
  517. CALL CQ8JCE(iGau,NBNN,E3,XEL,WORK(1),WORK(21),
  518. . TXR,SHPTOT,XJ,DJAC,IRR)
  519. IF (IRR.LT.0) THEN
  520. INTERR(1)=IB
  521. CALL ERREUR(405)
  522. GOTO 200
  523. ENDIF
  524. DJAC=ABS(DJAC)*POIGAU(iGau)
  525. ESTEL=ESTEL+FACSCA*DJAC
  526. C= 3.12.3.2 - Elements JOINTS 2D
  527. ELSE IF (MFR.EQ.35.AND.IDIM.EQ.2) THEN
  528. DO i=1,NBNO
  529. SHP(1,i)=SHPTOT(1,i,iGau)
  530. SHP(2,i)=SHPTOT(2,i,iGau)
  531. ENDDO
  532. DXDKSI=0.
  533. DYDKSI=0.
  534. DO i=1,NBNO/2
  535. DXDKSI=DXDKSI+SHP(2,i)*XEL(1,i)
  536. DYDKSI=DYDKSI+SHP(2,i)*XEL(2,i)
  537. ENDDO
  538. DJAC=SQRT(DXDKSI*DXDKSI+DYDKSI*DYDKSI)*POIGAU(iGau)
  539. ESTEL=ESTEL+FACSCA*DJAC
  540. C= 3.12.3.3 - Elements JOINTS 3D (JOT3 et JOI4)
  541. ELSE IF (MFR.EQ.35.AND.IDIM.EQ.3) THEN
  542. DO i=1,NBNO
  543. SHP(1,i)=SHPTOT(1,i,iGau)
  544. SHP(2,i)=SHPTOT(2,i,iGau)
  545. SHP(3,i)=SHPTOT(3,i,iGau)
  546. ENDDO
  547. IF (MELE.EQ.87) THEN
  548. CALL JT3LOC(XEL,SHPTOT,NBNO,XE,BPSS,NOQUAL)
  549. IF (NOQUAL.EQ.1) THEN
  550. INTERR(1)=IB
  551. MOTERR(1:4)='JOT3'
  552. CALL ERREUR(765)
  553. GOTO 200
  554. ELSE IF (NOQUAL.EQ.2) THEN
  555. INTERR(1)=IB
  556. MOTERR(1:4)='JOT3'
  557. CALL ERREUR(766)
  558. GOTO 200
  559. ENDIF
  560. ELSE IF (MELE.EQ.88) THEN
  561. CALL JO4LOC(XEL,SHPTOT,NBNO,XE,BPSS,NOQUAL)
  562. IF (NOQUAL.EQ.1) THEN
  563. INTERR(1)=IB
  564. MOTERR(1:4)='JOI4'
  565. CALL ERREUR(765)
  566. GOTO 200
  567. ELSE IF (NOQUAL.EQ.2) THEN
  568. INTERR(1)=IB
  569. MOTERR(1:4)='JOI4'
  570. CALL ERREUR(766)
  571. GOTO 200
  572. ENDIF
  573. ENDIF
  574. NBNONN=NBNO/2
  575. CALL DEVOLU(XE,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC)
  576. IRRT=0
  577. IF (DJAC.LT.0.) THEN
  578. IRRT=1
  579. ELSE IF (DJAC.EQ.0.) THEN
  580. IRRT=2
  581. ENDIF
  582. IF (IRRT.NE.0) THEN
  583. CALL ERREUR(764)
  584. GOTO 200
  585. ENDIF
  586. ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau)
  587. C
  588. C JOINTS POREUX
  589. ELSE IF ((MELE.GE.108.AND.MELE.LE.110).OR.
  590. & (MELE.GE.185.AND.MELE.LE.190)) THEN
  591.  
  592. DO LAD=1,IDIM
  593. DO i=1,NBNO
  594. SHP(LAD,i)=SHPTOT(LAD,i,iGau)
  595. ENDDO
  596. ENDDO
  597. CALL JOPLOC(XEL,SHPTOT,NBBB,NBNO,IFOUR,XE,BPSS)
  598. CALL DEVOLJ(XEL,XE,SHP,NBBB,NBNO,IFOUR,DJAC)
  599. ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau)
  600.  
  601. C= 3.12.3.4 - Elements zone cohesive ZCO2
  602. ELSE IF (MFR.EQ.77.AND.IDIM.EQ.2) THEN
  603. DO i=1,NBNO
  604. SHP(1,i)=SHPTOT(1,i,iGau)
  605. SHP(2,i)=SHPTOT(2,i,iGau)
  606. ENDDO
  607. DXDKSI=0.
  608. DYDKSI=0.
  609. DO i=1,NBNO
  610. DXDKSI=DXDKSI+SHP(2,i)*XEL(1,i)
  611. DYDKSI=DYDKSI+SHP(2,i)*XEL(2,i)
  612. ENDDO
  613. DJAC=SQRT(DXDKSI*DXDKSI+DYDKSI*DYDKSI)*POIGAU(iGau)
  614. ESTEL=ESTEL+FACSCA*DJAC
  615. C= 3.12.3.3 - Elements zone cohesive ZCO3ou4
  616. ELSE IF (MFR.EQ.77.AND.IDIM.EQ.3) THEN
  617. DO i=1,NBNO
  618. SHP(1,i)=SHPTOT(1,i,iGau)
  619. SHP(2,i)=SHPTOT(2,i,iGau)
  620. SHP(3,i)=SHPTOT(3,i,iGau)
  621. ENDDO
  622. dXdQsi=REAL(0.D0)
  623. dYdQsi=REAL(0.D0)
  624. dZdQsi=REAL(0.D0)
  625. dXdEta=REAL(0.D0)
  626. dYdEta=REAL(0.D0)
  627. dZdEta=REAL(0.D0)
  628. DO i=1,NBNO
  629. dXdQsi=dXdQsi+SHP(2,i)*XEL(1,i)
  630. dXdEta=dXdEta+SHP(3,i)*XEL(1,i)
  631. dYdQsi=dYdQsi+SHP(2,i)*XEL(2,i)
  632. dYdEta=dYdEta+SHP(3,i)*XEL(2,i)
  633. dZdQsi=dZdQsi+SHP(2,i)*XEL(3,i)
  634. dZdEta=dZdEta+SHP(3,i)*XEL(3,i)
  635. ENDDO
  636. z = (dXdQsi*dYdEta-dXdEta*dYdQsi)
  637. x = (dYdQsi*dZdEta-dYdEta*dZdQsi)
  638. y = (dZdQsi*dXdEta-dZdEta*dXdQsi)
  639. DJAC = sqrt(x*x+y*y+z*z)
  640. IRRT=0
  641. IF (DJAC.LT.0.) THEN
  642. IRRT=1
  643. ELSE IF (DJAC.EQ.0.) THEN
  644. IRRT=2
  645. ENDIF
  646. IF (IRRT.NE.0) THEN
  647. CALL ERREUR(764)
  648. GOTO 200
  649. ENDIF
  650. ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau)
  651. C= 3.12.3.4 - Autres elements
  652. ELSE
  653. IF (IFOMOD.EQ.2) THEN
  654. IDK=4
  655. ELSE IF (IFOMOD.GE.-1.AND.IFOMOD.LE.1) THEN
  656. IDK=3
  657. ELSE IF (IFOMOD.GE.3.AND.IFOMOD.LE.5) THEN
  658. IDK=2
  659. ENDIF
  660. DO j=1,NBNO
  661. DO i=1,IDK
  662. SHP(i,j)=SHPTOT(i,j,iGau)
  663. ENDDO
  664. ENDDO
  665. CALL GTEMRD(XEL,SHP,JDIM,NBNO,DJAC)
  666. IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1.OR.
  667. . IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  668. CALL DISTRR(XEL,SHP,NBNO,RR)
  669. IF (IFOMOD.EQ.5) THEN
  670. DJAC=X4Pi*RR*RR*DJAC
  671. ELSE IF (IFOMOD.EQ.1.AND.NIFOUR.NE.0) THEN
  672. DJAC=XPi*RR*DJAC
  673. ELSE
  674. DJAC=X2Pi*RR*DJAC
  675. ENDIF
  676. ENDIF
  677. C= 3.12.3.5 - Recuperation des caracteristiques selon l'element
  678. C= En dimension 1 (1D), pas de caracteristiques actuellement
  679. DIM3=1.
  680. FACAR=1.
  681. IF (IVACAR.EQ.0) GOTO 80
  682. MPTVAL=IVACAR
  683. c 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
  684. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4,
  685. c 17 20 23 24 25 26 27 28 29 30 33
  686. . 4,99,99,99,99,99, 4, 4, 4, 4,27,27,29,99,99,99,99
  687. c 34 35 40 41 42 43 44 45 46 47 48 49
  688. . ,99, 4, 4, 4, 4, 4, 4,27,29,99,27,99,27,99,99,27
  689. c 50 56 57 65
  690. . ,99,99,99,99,99,99,27, 4, 4, 4, 4,4, 4, 4, 4, 4,
  691. . 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,4, 4,
  692. . 4,29,99,99,99,99,99,99,99,99,27,99,99,99,99,99,99
  693. . ,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99
  694. . ,99,99,99,99,99,99,99,99,27,27),MELE
  695. 99 MOTERR(1:4)=NOMTP(MELE)
  696. MOTERR(5:12)='INTGCA'
  697. CALL ERREUR(86)
  698. GOTO 200
  699. C= 3.12.3.6 - Caracteristiques pour les elements MASSIFS
  700. 4 MELVAL=IVAL(1)
  701. IF (MELVAL.NE.0) THEN
  702. IGMN=MIN(iGau,VELCHE(/1))
  703. IBMN=MIN(IB,VELCHE(/2))
  704. FACAR=VELCHE(IGMN,IBMN)
  705. ENDIF
  706. GOTO 80
  707. C= 3.12.3.7 - Caracteristiques pour les elements COQUES et BARRES
  708. 27 MELVAL=IVAL(1)
  709. IGMN=MIN(iGau,VELCHE(/1))
  710. IBMN=MIN(IB, VELCHE(/2))
  711. FACAR=VELCHE(IGMN,IBMN)
  712. IF (MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  713. MELVAL=IVAL(3)
  714. IF (MELVAL.NE.0) DIM3=VELCHE(IGMN,IBMN)
  715. ENDIF
  716. GOTO 80
  717. C= 3.12.3.8 - Caracteristiques pour les elements POUTRES et TUYAUX
  718. C= Traitement particulier pour les TUYAUX
  719. 29 DO i=1,NCARR
  720. IF (IVAL(i).NE.0) THEN
  721. MELVAL=IVAL(i)
  722. IGMN=MIN(iGau,VELCHE(/1))
  723. IBMN=MIN(IB,VELCHE(/2))
  724. WORK(i)=VELCHE(IGMN,IBMN)
  725. ENDIF
  726. ENDDO
  727. IF (IVECT.EQ.1) THEN
  728. IF (IVAL(NCARR).NE.0) THEN
  729. MELVAL=IVAL(NCARR)
  730. IBMN=MIN(IB,IELCHE(/2))
  731. IREF=(IELCHE(1,IBMN)-1)*(IDIM+1)
  732. DO i=1,IDIM
  733. WORK(NCARR+i-1)=XCOOR(IREF+i)
  734. ENDDO
  735. ELSE
  736. DO i=0,IDIM-1
  737. WORK(NCARR+i)=0.
  738. ENDDO
  739. ENDIF
  740. ENDIF
  741. IF (MELE.EQ.42) THEN
  742. CISA=WORK(4)
  743. VX=WORK(5)
  744. VY=WORK(6)
  745. VZ=WORK(7)
  746. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  747. ENDIF
  748. FACAR=WORK(4)
  749. GOTO 80
  750. C= 3.12.3.9 - Calcul de la composante integree en ce point de Gauss
  751. 80 DJAC=ABS(DJAC)*POIGAU(iGau)*FACAR*DIM3
  752. ESTEL=ESTEL+FACSCA*DJAC
  753. ENDIF
  754. ENDDO
  755. C= 3.12.4 - Ajout de la contribution de cet element au resultat
  756. C= et le cas echeant au MCHAML au centre de gravite
  757. XRET=XRET+ESTEL
  758. IF (KOPELE.NE.0) THEN
  759. IBMN=MIN(IB,MELVA2.VELCHE(/2))
  760. MELVA2.VELCHE(1,IBMN)=ESTEL
  761. ENDIF
  762. ENDDO
  763. C ======
  764. C 3.13 - Desactivation/suppression de segments associes a iSou
  765. C Sortie prematuree en cas d'ERREUR (iOK=0)
  766. C ======
  767. iOK=1
  768. 200 SEGSUP,MWRK1
  769. IF (LOGCOQ) THEN
  770. SEGSUP,MWRK2
  771. SEGDES,MINTE1
  772. SEGSUP,MWRK3
  773. ELSE IF (IPCHE2.NE.0) THEN
  774. SEGSUP,MWRK3
  775. ENDIF
  776. SEGDES,MELEME
  777. 210 CALL DTMVAL(IVACAR,1)
  778. 220 NOMID=MOCARA
  779. IF (MOCARA.NE.0) SEGSUP,NOMID
  780. IF (IPMEL1.NE.0) THEN
  781. IF (ISup1.EQ.1) THEN
  782. SEGSUP,MELVA1
  783. ELSE
  784. SEGDES,MELVA1
  785. ENDIF
  786. ENDIF
  787. 230 CALL DTMVAL(IVACOM,1)
  788. SEGDES,MINTE
  789. 240 CONTINUE
  790. 250 SEGDES,IMODEL
  791. IF (iOK.EQ.0) THEN
  792. IF (KOPELE.NE.0) THEN
  793. IF (IPMEL2.NE.0) SEGSUP,MELVA2
  794. IF (MCHAML.NE.0) SEGSUP,MCHAML
  795. SEGSUP,MCHELM
  796. ENDIF
  797. GOTO 300
  798. ENDIF
  799. IF (KOPELE.NE.0) SEGDES,MELVA2,MCHAML
  800. 2000 continue
  801.  
  802.  
  803. C 4 - MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
  804. C ====================================================
  805. IRET=1
  806. IF (KOPELE.NE.0)then
  807. if( n1.ne.isouss) then
  808. n1=isouss
  809. segadj mchelm
  810. endif
  811. SEGDES,MCHELM
  812. ENDIF
  813. 300 NOMID=MOCOMP
  814. NOTYPE=MOTYCO
  815. SEGSUP,NOTYPE,NOMID
  816. SEGDES,MMODEL,MCHEL1
  817.  
  818. RETURN
  819. END
  820.  
  821.  
  822.  
  823.  
  824.  
  825.  
  826.  

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