Télécharger intgca.eso

Retour à la liste

Numérotation des lignes :

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

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