Télécharger intgca.eso

Retour à la liste

Numérotation des lignes :

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

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