Télécharger grad1.eso

Retour à la liste

Numérotation des lignes :

  1. C GRAD1 SOURCE GF238795 18/02/05 21:15:16 9726
  2.  
  3. C=======================================================================
  4. C= G R A D 1 =
  5. C= --------- =
  6. C= =
  7. C= Fonction : =
  8. C= ---------- =
  9. C= Traitement des informations necessaires au calcul du gradient d'un =
  10. C= champ deplacement/temperature. Branchement suivant l'element fini. =
  11. C= Sous-programme appele par GRAD (grad.eso) =
  12. C= =
  13. C= Parametres : (E)=Entree (S)=Sortie =
  14. C= ------------ =
  15. C= IPMODL (E) Pointeur sur segment MMODEL =
  16. C= IPCHE2 (E) Pointeur sur segment MCHELM de DEPLACEMENT/TEMPER. =
  17. C= IPCHE1 (E) Pointeur sur segment MCHELM de CARACTERISTIQUES =
  18. C= IPCHL1 (S) Pointeur sur segment MCHELM de GRADIENT resultat =
  19. C= IRET (S) Entier valant 1 en cas de succes, 0 sinon (et un =
  20. C= message d'erreur est imprime dans ce cas) =
  21. C= =
  22. C= Remarque : En entree du sousprogramme, IPCHL1 contient le CHPOINT =
  23. C= ---------- de deplacement ou de temperature fourni a l'operateur =
  24. C= 'GRAD'. Dans le cas d'un modele MECANIQUE, ce CHPOINT =
  25. C= est indispensable a avoir pour calculer les deforma- =
  26. C= generalisees au(x) point(s) support(s). =
  27. C= =
  28. C= Christian LE BRETON - Denis ROBERT-MOUGIN, le 31 juillet 1986. =
  29. C= Modifications aux nouvelles normes I.MONNIER, le 28 mai 1990. =
  30. C=======================================================================
  31.  
  32. SUBROUTINE GRAD1 (IPMODL,IPCHE2,IPCHE1, IPCHL1,IRET)
  33.  
  34. IMPLICIT INTEGER(I-N)
  35. IMPLICIT REAL*8 (A-H,O-Z)
  36.  
  37. -INC CCOPTIO
  38. -INC CCHAMP
  39. -INC CCREEL
  40.  
  41. -INC SMCHAML
  42. -INC SMMODEL
  43. -INC SMELEME
  44. -INC SMINTE
  45. -INC SMCOORD
  46. -INC SMLREEL
  47.  
  48. SEGMENT INFO
  49. INTEGER INFELL(JG)
  50. ENDSEGMENT
  51.  
  52. SEGMENT NOTYPE
  53. CHARACTER*16 TYPE(NBTYPE)
  54. ENDSEGMENT
  55.  
  56. SEGMENT MPTVAL
  57. INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  58. CHARACTER*16 TYVAL(NCOSOU)
  59. ENDSEGMENT
  60.  
  61. SEGMENT MVELCH
  62. REAL*8 VALMAT(NV1)
  63. ENDSEGMENT
  64.  
  65. SEGMENT MWRK1
  66. REAL*8 XDDL(LRE),XE(3,NBNO),GRADI(NGRA)
  67. REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS)
  68. ENDSEGMENT
  69.  
  70. SEGMENT MWRK2
  71. REAL*8 SHPWRK(6,NBNO),BGR(NGRA,LRE),BB(2,NGRA)
  72. ENDSEGMENT
  73.  
  74. SEGMENT MWRK3
  75. REAL*8 WORK(LW)
  76. ENDSEGMENT
  77.  
  78. SEGMENT MWRK4
  79. REAL*8 BPSS(3,3),XEL(3,NBNO),XDDLOC(LRE)
  80. ENDSEGMENT
  81.  
  82. PARAMETER (NINF=3)
  83. INTEGER INFOS(NINF)
  84. CHARACTER*8 CMATE
  85. CHARACTER*(NCONCH) CONM
  86.  
  87. DIMENSION UDPGE(3)
  88. LOGICAL LDPGE,lsupgd,lsupdp
  89. INTEGER ISUP1
  90.  
  91. IRET=0
  92. ISUP1=0
  93. iMess=0
  94.  
  95. C 1 - QUELQUES INITIALISATIONS
  96. C ==============================
  97. C 1.1 - Activation du MMODEL
  98. C =====
  99. MMODEL=IPMODL
  100. SEGACT,MMODEL
  101. NSOUS=KMODEL(/1)
  102. C
  103. KEL22 = 0
  104. DO ISOUS = 1,NSOUS
  105. IMODEL=KMODEL(ISOUS)
  106. SEGACT IMODEL
  107. IF (FORMOD(1).EQ.'CHARGEMENT') KEL22 = KEL22 + 1
  108. SEGDES IMODEL
  109. ENDDO
  110. C
  111. C =====
  112. C 1.2 - Cas des modes de calculs en DEFORMATIONS GENERALISEES
  113. C En mecanique, on conserve le CHPOINT de deplacements pour
  114. C calculer les deplacements du point support en DPGE (IPCHP1)
  115. C =====
  116. IPCHP1 = IPCHL1
  117. C =====
  118. C 1.3 - Activation du MCHELM resultat du champ de gradients
  119. C =====
  120. L1=8
  121. N1=NSOUS-KEL22
  122. N3=6
  123. SEGINI,MCHELM
  124. TITCHE='GRADIENT'
  125. IFOCHE=IFOUR
  126. IPCHL1=MCHELM
  127. C =====
  128. C 1.4 - Les composantes des champs de deplacement/temperature, de
  129. C gradient resultat sont toutes du meme type ('REAL*8') sur tout
  130. C le modele IPMODL. Le segment MOTYCH de type NOTYPE associe est
  131. C donc initialise une seule fois.
  132. C =====
  133. NBTYPE=1
  134. SEGINI,NOTYPE
  135. TYPE(1)='REAL*8'
  136. MOTYCH=NOTYPE
  137.  
  138. C 2 - BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE (iSou)
  139. C ========================================================
  140. isouss=0
  141. DO 2000 iSou=1,NSOUS
  142. C =====
  143. C 2.1 - Quelques initialisations
  144. C =====
  145. NDEP=0
  146. MODEPL=0
  147. IVADEP=0
  148. NGRA=0
  149. MOGRAD=0
  150. IVAGRA=0
  151. MOCARA=0
  152. IVACAR=0
  153. MOMATR=0
  154. IVAMAT=0
  155. MWRK1=0
  156. MWRK2=0
  157. MWRK3=0
  158. MWRK4=0
  159. MCHAML=0
  160. MELVAL=0
  161. MVELCH=0
  162. C =====
  163. C 2.2 - Activation du sous-modele (iSou)
  164. C =====
  165. IMODEL=KMODEL(iSou)
  166. SEGACT,IMODEL
  167. C
  168. IF (FORMOD(1).EQ.'CHARGEMENT') THEN
  169. SEGDES IMODEL
  170. GOTO 2000
  171. ENDIF
  172. C
  173. NFOR = formod(/2)
  174. CALL PLACE(FORMOD,NFOR,iliais,'LIAISON')
  175. iaffai=1
  176. DO iou=1,matmod(/2)
  177. if (matmod(iou).eq.'MODAL' .or. matmod(iou).eq.'STATIQUE' .or.
  178. $ matmod(iou).eq.'IMPEDANCE') iaffai=0
  179. ENDDO
  180. IF (iaffai.eq.0 .or. iliais.ne.0) then
  181. segdes imodel
  182. GOTO 2000
  183. ENDIF
  184. MELE=NEFMOD
  185. * au cas ou il y en aurait besoin
  186. IF (mele.eq.22.or.mele.eq.259.or.mele.eq.50000) then
  187. segdes imodel
  188. go to 2000
  189. endif
  190. isouss=isouss+1
  191. IPMAIL=IMAMOD
  192. CONM=CONMOD
  193. C =====
  194. C 2.3 - Determination ...
  195. C =====
  196. CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,iOK)
  197. IF (iOK.EQ.0) GOTO 200
  198. iOK=0
  199. C =====
  200. C 2.4 - Determination de la nature du materiau et verification
  201. C =====
  202. NFOR=FORMOD(/2)
  203. CMATE = CMATEE
  204. MATE = IMATEE
  205. *NU INAT = INATUU
  206. IF (CMATE.EQ.' ') THEN
  207. CALL ERREUR(251)
  208. GOTO 200
  209. ENDIF
  210. CALL PLACE(FORMOD,NFOR,ITHEHY,'THERMOHYDRIQUE')
  211. CALL PLACE(FORMOD,NFOR,ITHER ,'THERMIQUE' )
  212. CALL PLACE(FORMOD,NFOR,IDIFF ,'DIFFUSION' )
  213. C =====
  214. C 2.5 - Recuperation d'informations lies au maillage IPMAIL
  215. C =====
  216. MELEME=IPMAIL
  217. SEGACT,MELEME
  218. NBNN=NUM(/1)
  219. NBELEM=NUM(/2)
  220. NBNO=NBNN
  221. C =====
  222. C 2.6 - Recuperation d'informations sur l'element fini du sous-modele
  223. C suivant la formulation du modele (MECANIQUE ou THERMIQUE)
  224. C =====
  225. C SP 07/08 : NII=Nombre Inconnues Independantes
  226. C (e.g. T,Pc,Pg en Thermohydrique)
  227. NII=1
  228. IPINF=0
  229. IF (ITHEHY.NE.0) THEN
  230. MFR=65
  231. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  232. IPMIN1=0
  233. NII=3
  234. LRE=NII*NBNN
  235. C*OF : Valeur de LW ?
  236. LW=1700
  237. NSTRS=0
  238. LDPGE = .FALSE.
  239. NDPGE = 0
  240. ELSE IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  241. MFR=NUMMFR(MELE)
  242. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  243. IPMIN1=0
  244. IF (MFR.EQ.5.OR.MFR.EQ.9) THEN
  245. CALL TSHAPE(MELE,'NOEUD',IPMIN1)
  246. ENDIF
  247. IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  248. LRE=3*NBNN
  249. ELSE
  250. LRE=NBNN
  251. ENDIF
  252. C*OF : Valeur de LW ?
  253. LW=1700
  254. NSTRS=0
  255. LDPGE = .FALSE.
  256. NDPGE = 0
  257. c ajout bp du 18/06/2013 : il faut renseigner NPINT pour idtemp
  258. NPINT=0
  259. IF(INFMOD(/1).NE.0) NPINT=INFMOD(1)
  260. ELSE
  261. if(infmod(/1).lt.7)then
  262. CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  263. INFO=IPINF
  264. IF (IERR.NE.0) GOTO 210
  265. MFR=INFELL(13)
  266. IPMINT=INFELL(11)
  267. IPMIN1=INFELL(12)
  268. LRE=INFELL(9)
  269. LW=INFELL(7)
  270. LHOOK=INFELL(10)
  271. NSTRS=INFELL(16)
  272. segsup info
  273. else
  274. MFR=INFELE(13)
  275. * IPMINT=INFELE(11)
  276. ipmint=infmod(7)
  277. IPMIN1=INFMOD(8)
  278. LRE=INFELE(9)
  279. LW=INFELE(7)
  280. LHOOK=INFELE(10)
  281. NSTRS=INFELE(16)
  282. endif
  283. CALL INFDPG(MFR,IFOUR, LDPGE,NDPGE)
  284. ENDIF
  285. C =====
  286. C 2.6 - Recherche des DDL du noeud support des def. planes generalisees
  287. C Dans ce cas, IPCHP1 est fourni a GRAD via IPCHL1 (cf. 1.3)
  288. C =====
  289. IF (LDPGE) THEN
  290. IF (IPCHP1.EQ.0) THEN
  291. CALL ERREUR(621)
  292. GOTO 210
  293. ENDIF
  294. IIPDPG = imodel.IPDPGE
  295. IIPDPG = IPTPOI(IIPDPG)
  296. IF (IIPDPG.EQ.0) THEN
  297. CALL ERREUR(925)
  298. CALL ERREUR(5)
  299. GOTO 210
  300. ENDIF
  301. CALL DEPDPG(IPCHP1,UDPGE(1),UDPGE(2),UDPGE(3),IIPDPG)
  302. ELSE
  303. IIPDPG = 0
  304. ENDIF
  305. C =====
  306. C 2.7 - Segment d'integration
  307. C =====
  308. MINTE=IPMINT
  309. SEGACT,MINTE
  310. NBPGAU=POIGAU(/1)
  311. C =====
  312. C 2.8 - Recuperation des noms des caracteristiques GEOMETRIQUES
  313. C Verification de leur presence dans le MCHAML (IPCHE1)
  314. C =====
  315. NBROBL=0
  316. NBRFAC=0
  317. IVECT =0
  318. if (iaffai.eq.1.and.iliais.eq.0) then
  319. C= 2.8.1 - Elements COQUES : epaisseur et excentrement
  320. IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  321. NBROBL=1
  322. NBRFAC=1
  323. SEGINI,NOMID
  324. LESOBL(1)='EPAI'
  325. LESFAC(1)='EXCE'
  326. MOCARA=NOMID
  327. NBTYPE=1
  328. SEGINI,NOTYPE
  329. TYPE(1)='REAL*8'
  330. C= 2.8.2 - Elements BARREs
  331. ELSE IF (MFR.EQ.27) THEN
  332. NBROBL=1
  333. SEGINI NOMID
  334. MOCARA=NOMID
  335. LESOBL(1)='SECT'
  336. NBTYPE=1
  337. SEGINI NOTYPE
  338. TYPE(1)='REAL*8'
  339. C= 2.8.3 - Elements BARREs EXCENTREES : section, excentrements et orientation
  340. ELSE IF (MFR.EQ.49) THEN
  341. NBROBL=6
  342. SEGINI NOMID
  343. MOCARA=NOMID
  344. LESOBL(1)='SECT'
  345. LESOBL(2)='EXCZ'
  346. LESOBL(3)='EXCY'
  347. LESOBL(4)='VX '
  348. LESOBL(5)='VY '
  349. LESOBL(6)='VZ '
  350. NBTYPE=1
  351. SEGINI NOTYPE
  352. TYPE(1)='REAL*8'
  353.  
  354. C= 2.8.4 - Elements POUTRES
  355. ELSE IF (MFR.EQ.7) THEN
  356. IF (CMATE.EQ.'SECTION') THEN
  357. NBROBL=0
  358. NBRFAC=1
  359. SEGINI NOMID
  360. MOCARA=NOMID
  361. LESFAC(1)='VECT'
  362. IVECT=1
  363.  
  364. NBTYPE=1
  365. SEGINI NOTYPE
  366. TYPE(1)='POINTEURPOINT '
  367. ELSE
  368. IF(IFOUR.EQ.2) THEN
  369. NBROBL=4
  370. NBRFAC=3
  371. SEGINI NOMID
  372. MOCARA=NOMID
  373. LESOBL(1)='TORS'
  374. LESOBL(2)='INRY'
  375. LESOBL(3)='INRZ'
  376. LESOBL(4)='SECT'
  377. LESFAC(1)='SECY'
  378. LESFAC(2)='SECZ'
  379. LESFAC(3)='VECT'
  380. IVECT=1
  381. NBTYPE=7
  382. SEGINI NOTYPE
  383. TYPE(1)='REAL*8'
  384. TYPE(2)='REAL*8'
  385. TYPE(3)='REAL*8'
  386. TYPE(4)='REAL*8'
  387. TYPE(5)='REAL*8'
  388. TYPE(6)='REAL*8'
  389. TYPE(7)='POINTEURPOINT '
  390. ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
  391. NBRFAC=1
  392. NBROBL=2
  393. SEGINI NOMID
  394. MOCARA=NOMID
  395. LESOBL(1)= 'SECT'
  396. LESOBL(2)= 'INRZ'
  397. LESFAC(1)= 'SECY'
  398. NBTYPE=1
  399. SEGINI NOTYPE
  400. TYPE(1)='REAL*8'
  401. ENDIF
  402. ENDIF
  403. C= 2.8.5 - Elements POUTRES TIMO 2D :
  404. C* non defini actuellement
  405. C= 2.8.6 - Elements TUYAUX
  406. ELSE IF (MFR.EQ.13) THEN
  407. NBROBL=2
  408. NBRFAC=3
  409. SEGINI NOMID
  410. MOCARA=NOMID
  411. LESOBL(1)='EPAI'
  412. LESOBL(2)='RAYO'
  413. LESFAC(1)='RACO'
  414. LESFAC(2)='CISA'
  415. LESFAC(3)='VECT'
  416. IVECT=1
  417. NBTYPE=5
  418. SEGINI NOTYPE
  419. TYPE(1)='REAL*8'
  420. TYPE(2)='REAL*8'
  421. TYPE(3)='REAL*8'
  422. TYPE(4)='REAL*8'
  423. TYPE(5)='POINTEURPOINT '
  424. ENDIF
  425. endif
  426. NCARA=NBROBL
  427. NCARF=NBRFAC
  428. NCAR =NBROBL+NBRFAC
  429. C= 2.8.x - Verification de la presence des caracteristiques dans IPCHE1
  430. IF (NCAR.NE.0) THEN
  431. IF (IPCHE1.NE.0) THEN
  432. MOTYPE=NOTYPE
  433. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  434. . INFOS,3,IVACAR)
  435. SEGSUP,NOTYPE
  436. IF (IERR.NE.0) GOTO 220
  437. * IF (IVACAR.NE.0) THEN
  438. * MPTVAL=IVACAR
  439. * IPMELV=IVAL(1)
  440. * CALL QUELCH(IPMELV,ICONS)
  441. * IF (ICONS.NE.0) THEN
  442. * CALL ERREUR(566)
  443. * GOTO 220
  444. * ENDIF
  445. * ENDIF
  446. * CAS DES POUTRES : TRAITEMENT DES VECTEURS
  447. IF (IVECT.EQ.1) THEN
  448. MPTVAL=IVACAR
  449. IF (IVAL(NCAR).EQ.0) THEN
  450. C MOT CLE VECT EN CAS DE CONVERSION
  451. segsup mptval
  452. IVECT=2
  453. NOMID=MOCARA
  454. C* SEGACT NOMID
  455. NBRFAC=NBRFAC+2
  456. SEGADJ NOMID
  457. LESFAC(NBRFAC-2)='VX '
  458. LESFAC(NBRFAC-1)='VY '
  459. LESFAC(NBRFAC) ='VZ '
  460. NCARF=NBRFAC
  461. NCAR=NCARA+NCARF
  462. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYCH,
  463. $ 1,INFOS,3,IVACAR)
  464. IF (IERR.NE.0) GOTO 220
  465. ENDIF
  466. ENDIF
  467. ELSE
  468. MOTERR(1:8)='CARACTER'
  469. MOTERR(9:12)=NOMTP(MELE)
  470. MOTERR(13:20)='GRAD'
  471. CALL ERREUR(145)
  472. GOTO 220
  473. ENDIF
  474. ENDIF
  475. C =====
  476. C 2.9.1 - Traitement particulier dans le cas de l'element COQUE DST
  477. C Recuperation des donnees contenues dans la matrice de HOOKE
  478. C Verification de leur presence dans le MCHAML (IPCHE1)
  479. C =====
  480. NMATR=0
  481. NMATF=0
  482. NMATT=0
  483. IF (MELE.EQ.93) THEN
  484. IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  485. NBROBL=2
  486. NBRFAC=0
  487. SEGINI,NOMID
  488. LESOBL(1)='YOUN'
  489. LESOBL(2)='NU '
  490. MOMATR=NOMID
  491. NMATR=NBROBL
  492. NMATF=NBRFAC
  493. IF (IPCHE1.NE.0) THEN
  494. C*OF : On va utiliser MOTYCH pour gagner un peu de temps
  495. C*OF NBTYPE=1
  496. C*OF SEGINI,NOTYPE
  497. C*OF TYPE(1)='REAL*8'
  498. C*OF MOTYPE=NOTYPE
  499. C*OF CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,
  500. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYCH,1,
  501. . INFOS,3,IVAMAT)
  502. IF (IERR.NE.0) GOTO 230
  503. C*OF SEGSUP,NOTYPE
  504. ELSE
  505. SEGSUP,NOTYPE
  506. MOTERR(1:8)='CARACTER'
  507. MOTERR(9:12)=NOMTP(MELE)
  508. MOTERR(13:20)='GRAD'
  509. CALL ERREUR(145)
  510. GOTO 230
  511. ENDIF
  512. NMATT=NMATR+NMATF
  513. MPTVAL=IVAMAT
  514. NBGMAT=0
  515. NELMAT=0
  516. DO i=1,NMATT
  517. IF (IVAL(i).NE.0)THEN
  518. MELVAL=IVAL(i)
  519. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  520. NELMAT=MAX(NELMAT,VELCHE(/2))
  521. ENDIF
  522. ENDDO
  523. ENDIF
  524. ENDIF
  525. C =====
  526. C 2.9.2 - Cas d'un joint unidimensionnel JOI1
  527. C Chargement des vecteurs stitués dans les caractéristiques matériau
  528. C =====
  529. IF(MFR.EQ.75) THEN
  530. IF(IDIM.EQ.3) THEN
  531. NBROBL=6
  532. NBRFAC=0
  533. SEGINI NOMID
  534. MOMATR=NOMID
  535. LESOBL(1)='V1X'
  536. LESOBL(2)='V1Y'
  537. LESOBL(3)='V1Z'
  538. LESOBL(4)='V2X'
  539. LESOBL(5)='V2Y'
  540. LESOBL(6)='V2Z'
  541. NMATR=NBROBL
  542. NMATF=NBRFAC
  543. ELSE IF(IDIM.EQ.2) THEN
  544. NBROBL=2
  545. NBRFAC=0
  546. SEGINI NOMID
  547. MOMATR=NOMID
  548. LESOBL(1)='V1X'
  549. LESOBL(2)='V1Y'
  550. NMATR=NBROBL
  551. NMATF=NBRFAC
  552. ENDIF
  553. NBTYPE=1
  554. SEGINI NOTYPE
  555. TYPE(1)='REAL*8'
  556. MOTYPE=NOTYPE
  557. *
  558. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  559. SEGSUP NOTYPE
  560. IF (IERR.NE.0) GOTO 2000
  561. *
  562. NMATT=NMATR+NMATF
  563. * C
  564. IF(ISUP1.EQ.1)THEN
  565. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  566. IF(IERR.NE.0)THEN
  567. ISUP1=0
  568. GOTO 2000
  569. ENDIF
  570. ENDIF
  571. MPTVAL=IVAMAT
  572. NBGMAT = 0
  573. NELMAT = 0
  574. DO 11265 IM=1,NMATT
  575. IF(IVAL(IM).NE.0)THEN
  576. MELVAL=IVAL(IM)
  577. IF (CMATE.EQ.'SECTION') THEN
  578. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  579. NELMAT=MAX(NELMAT,IELCHE(/2))
  580. ELSE
  581. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  582. NELMAT=MAX(NELMAT,VELCHE(/2))
  583. ENDIF
  584. ENDIF
  585. 11265 CONTINUE
  586. nmattd=nmatt
  587. ivamtd= ivamat
  588. segdes nomid
  589. ENDIF
  590. C ======
  591. C 2.10 - Recuperation des noms des composantes de DEPL. ou T
  592. C Verification de leur presence dans le MCHAML (IPCHE2)
  593. C*OF Par abus : MODEPL noms des composantes de DEPL et de Temperatures
  594. C ======
  595. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  596. if(lNOMID(8).ne.0) then
  597. NOMID=lNOMID(8)
  598. segact NOMID
  599. modepl=NOMID
  600. ndep=lesobl(/2)
  601. nfac=lesfac(/2)
  602. lsupdp=.false.
  603. else
  604. lsupdp=.true.
  605. CALL IDTEMP(MFR,IFOUR,NPINT,MODEPL,NDEP,NFAC)
  606. endif
  607. IF (MFR.EQ.1) THEN
  608. MDM=29
  609. ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  610. MDM=39
  611. ENDIF
  612.  
  613. ELSE
  614. IF(LNOMID(1).NE.0) THEN
  615. NOMID=LNOMID(1)
  616. SEGACT NOMID
  617. MODEPL=NOMID
  618. ndep=LESOBL(/2)
  619. NFAC=LESFAC(/2)
  620. LSUPDP=.FALSE.
  621. ELSE
  622. LSUPDP=.TRUE.
  623. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEP,NFAC)
  624. ENDIF
  625. MDM=MFR
  626.  
  627. ENDIF
  628. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MODEPL,MOTYCH,1,INFOS,3,IVADEP)
  629. IF (IERR.NE.0) GOTO 240
  630. C ======
  631. C 2.11 - Recuperation des noms des composantes de gradient
  632. C ======
  633. IF(LNOMID(3).NE.0) then
  634. MOGRAD=LNOMID(3)
  635. NOMID=MOGRAD
  636. SEGACT,NOMID
  637. NGRA=LESOBL(/2)
  638. NFAC=LESFAC(/2)
  639. LSUPGD=.FALSE.
  640. ELSE
  641. LSUPGD=.TRUE.
  642. CALL IDGRAD(MDM,IFOUR,MOGRAD,NGRA,NFAC)
  643. NOMID=MOGRAD
  644. SEGACT,NOMID
  645. ENDIF
  646. C ======
  647. C 2.12 - Initialisation du MCHAML des gradients (MCHAML)
  648. C associe au modele elementaire iSou (de maillage IPMAIL)
  649. C Remplissage des donnees associees a MCHAML dans MCHELM(global)
  650. C ======
  651. C= 2.12.1 - Initialisation de MCHAML
  652. N2=NGRA
  653. SEGINI,MCHAML
  654. C= 2.12.2 - Remplissage de MCHEML(iSou)
  655. CONCHE(iSouss)=CONMOD
  656. IMACHE(iSouss)=IPMAIL
  657. ICHAML(iSouss)=MCHAML
  658. INFCHE(iSouss,1)=0
  659. INFCHE(iSouss,2)=0
  660. INFCHE(iSouss,3)=NIFOUR
  661. INFCHE(iSouss,4)=IPMINT
  662. INFCHE(iSouss,5)=0
  663. IF (ITHEHY.NE.0 .OR. ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  664. INFCHE(iSouss,6)=6
  665. ELSE
  666. INFCHE(iSouss,6)=5
  667. ENDIF
  668. C= 2.12.3 - Initialisation des N2 MELVAL associes a MCHAML
  669. C= Fin du remplissage de MCHAML
  670. N1EL=0
  671. N1PTEL=0
  672. MPTVAL=IVADEP
  673. DO i=1,NDEP
  674. MELVAL=IVAL(i)
  675. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  676. N1EL=MAX(N1EL,VELCHE(/2))
  677. ENDDO
  678. IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  679. N1PTEL=1
  680. ELSE
  681. N1PTEL=NBPGAU
  682. ENDIF
  683. N1EL=MIN(N1EL,NBELEM)
  684. * write(6,*) 'N1PTEL,N1EL=',N1PTEL,N1EL
  685. N2PTEL=0
  686. N2EL=0
  687. NS=1
  688. NCOSOU=NGRA
  689. SEGINI,MPTVAL
  690. NOMID=MOGRAD
  691. DO i=1,N2
  692. NOMCHE(i)=LESOBL(i)
  693. TYPCHE(i)='REAL*8'
  694. SEGINI,MELVAL
  695. IELVAL(i)=MELVAL
  696. IVAL(i)=MELVAL
  697. ENDDO
  698. IVAGRA=MPTVAL
  699. C ======
  700. C 2.13 - Initialisations de quelques valeurs
  701. C ======
  702. cbp NDDD=NDEP -> ne prend pas en compte les composantes facultatives
  703. MPTVAL=IVADEP
  704. NDDD=IVAL(/1)
  705. C* Attention si composantes facultatives en DPGE ??
  706. IF (LDPGE) NDDD=NDEP-NDPGE
  707. *
  708. IF (MFR.EQ.77) THEN
  709. * zones cohesives : on se limite aux composantes obligatoires
  710. NDDD=NDEP
  711. ENDIF
  712.  
  713. C POUR les XFEM on fait un cas particulier inspiré du cas massif
  714. IF (MFR.EQ.63) THEN
  715. CALL GRAD1X(IMODEL,IVADEP,LRE,IVAGRA,NGRA,
  716. & IPMINT,IPMIN1,IIPDPG,IOK)
  717. GOTO 260
  718. ELSE IF (MFR.EQ.29) THEN
  719. i=NGRA
  720. NGRA=i*NBNO
  721. SEGINI,MWRK1
  722. NGRA=i
  723. ELSE
  724. SEGINI,MWRK1
  725. ENDIF
  726. C
  727. IF (ITHEHY.NE.0) THEN
  728. LREII=LRE/NII
  729. NGRAII=NGRA/NII
  730. JG=LREII
  731. SEGINI,MLREE1
  732. JG=NGRAII
  733. SEGINI,MLREE2
  734. ENDIF
  735. IF (ITHEHY.NE.0 .OR. ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  736. NOELE=57
  737. ELSE
  738. NOELE=MELE
  739. ENDIF
  740. C ======
  741. C 2.14 - Boucle sur les elements du sous-modele elementaire
  742. C ======
  743.  
  744.  
  745. DO 100 IB=1,NBELEM
  746. C= 2.14.1 - Recuperation des coordonnees des noeuds de l'element
  747. CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE)
  748. C= 2.14.2 - Recuperation des deplacements/temperatures aux noeuds
  749. C= Traitement dans les cas des modes generalises
  750. MPTVAL=IVADEP
  751. IE=1
  752. DO iGau=1,NBNN
  753. DO i=1,NDDD
  754. MELVAL=IVAL(i)
  755. IF (MELVAL.NE.0) THEN
  756. IGMN=MIN(iGau,VELCHE(/1))
  757. IBMN=MIN(IB,VELCHE(/2))
  758. XDDL(IE)=VELCHE(IGMN,IBMN)
  759. ELSE
  760. XDDL(IE)=XZero
  761. ENDIF
  762. IE=IE+1
  763. ENDDO
  764. ENDDO
  765. IF (NDPGE.GT.0) THEN
  766. DO i=1,NDPGE
  767. XDDL(IE)=UDPGE(i)
  768. IE=IE+1
  769. ENDDO
  770. ENDIF
  771.  
  772. C= 2.14.3 - Branchement suivant l'element fini
  773. c 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
  774. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  775. c 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
  776. . 99,99, 4, 4, 4, 4,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
  777. . 41,29,99,44,99,99,99,99,49,99,99,99,99,99,99,41, 4, 4, 4, 4,
  778. . 4, 4, 4, 4, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,
  779. . 99,99,99,29,85,99,99,88,99,99,99,99,93,99,99,99,99,99,99,99,
  780. . 99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  781. . 4, 4),MELE
  782. IF (MELE.EQ.183.OR.MELE.EQ.184) GOTO 4
  783. IF (MELE.GE.191.AND.MELE.LE.194) GOTO 4
  784. IF (MELE.EQ.265) GOTO 265
  785. IF (MELE.EQ.266) GOTO 266
  786. IF (MELE.EQ.267) GOTO 267
  787. 99 CONTINUE
  788. C*OF On ne veut plus sortir sur une erreur :
  789. C* MOTERR(1:4)=NOMTP(MELE)
  790. C* MOTERR(9:12)='GRADIENT'
  791. C* iMess=86
  792. C*OF On met un champ de gradient nul pour les elements non implementes !
  793. N1PTEL=1
  794. N1EL=1
  795. N2PTEL=0
  796. N2EL=0
  797. DO i=1,IELVAL(/1)
  798. MELVAL=IELVAL(i)
  799. SEGADJ,MELVAL
  800. VELCHE(1,1)=XZero
  801. ENDDO
  802. iOK=1
  803. GOTO 250
  804. C= 2.14.4 - Elements MASSIFS et INCOMPRESSIBLES
  805. 4 CONTINUE
  806. IF (IB.EQ.1) SEGINI,MWRK2
  807. ISDJC=0
  808. DO iGau=1,NBPGAU
  809. C -- Calcul de la matrice B et du jacobien au point de Gauss IGAU
  810. IF (ITHEHY.NE.0) THEN
  811. CALL BGRMAS(iGau,NOELE,NBNO,LREII,IFOUR,NGRAII,NIFOUR,XE,
  812. . XZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  813. ELSE
  814. C= 2.14.4bis - Elements massifs en 'ELECTROSTATIQUE' et 'DIFFUSION'
  815. IF (MFR.EQ.71) THEN
  816. CALL BELEC(XE,SHPTOT(1,1,IGAU),NBNO,NGRA,+1,
  817. & SHPWRK,BGR,DJAC)
  818. ELSE IF (MFR.EQ.73) THEN
  819. CALL BDIFF(XE,SHPTOT(1,1,IGAU),NBNN,NGRA,+1,
  820. & SHPWRK,BGR,DJAC)
  821. ELSE
  822. C- Elements MASSIFS et INCOMPRESSIBLES en MECANIQUE
  823. CALL BGRMAS(iGau,NOELE,NBNO,LRE,IFOUR,NGRA,NIFOUR,XE,
  824. . XZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  825. ENDIF
  826. ENDIF
  827. IF (DJAC.LT.XZero) ISDJC=ISDJC+1
  828. IF (DJAC.EQ.XZero) THEN
  829. iMess=259
  830. GOTO 260
  831. ENDIF
  832. IF (ITHEHY.NE.0) THEN
  833. DO KII=1,NII
  834. DO LLL=1,LREII
  835. MLREE1.PROG(LLL)=XDDL(LLL*NII-(NII-KII))
  836. ENDDO
  837. CALL BGRDEP(BGR,NGRAII,MLREE1.PROG,LREII,MLREE2.PROG)
  838. DO LLL=1,NGRAII
  839. GRADI(LLL+(KII-1)*NGRAII)=MLREE2.PROG(LLL)
  840. ENDDO
  841. ENDDO
  842. ELSE
  843. IF (MFR.EQ.71 .OR. MFR.EQ.73) THEN
  844. CALL BST(BGR,XDDL,LRE,NGRA,GRADI)
  845. ELSE
  846. CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  847. ENDIF
  848. ENDIF
  849. MPTVAL=IVAGRA
  850. DO i=1,NGRA
  851. MELVAL=IVAL(i)
  852. IGMN=MIN(iGau,VELCHE(/1))
  853. IBMN=MIN(IB,VELCHE(/2))
  854. VELCHE(IGMN,IBMN)=GRADI(i)
  855. ENDDO
  856. ENDDO
  857. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  858. iMess=195
  859. GOTO 260
  860. ENDIF
  861. GOTO 100
  862. C= 2.14.5 - Elements COQUES COQ3 (thermique - mecanique)
  863. 27 IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  864. IF (IB.EQ.1) SEGINI,MWRK2
  865. ISDJC=0
  866. DO iGau=1,NBPGAU
  867. CALL CQTGR1(iGau,MELE,NBNN,LRE,IFOUR,NGRA,XE,SHPTOT,
  868. . XDDL,SHPWRK,BGR,DJAC,GRADI)
  869. IF (IERR.NE.0) GOTO 260
  870. IF (DJAC.EQ.XZero) THEN
  871. iMess=259
  872. GOTO 260
  873. ENDIF
  874. IF (DJAC.LT.XZero) ISDJC=ISDJC+1
  875. MPTVAL=IVAGRA
  876. DO i=1,NGRA
  877. MELVAL=IVAL(i)
  878. IGMN=MIN(iGau,VELCHE(/1))
  879. IBMN=MIN(IB,VELCHE(/2))
  880. VELCHE(IGMN,IBMN)=GRADI(i)
  881. ENDDO
  882. ENDDO
  883. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  884. iMess=195
  885. GOTO 260
  886. ENDIF
  887. ELSE
  888. C= COQ3 mecanique : un point d'integration au centre de gravite
  889. IF (IB.EQ.1) SEGINI,MWRK3
  890. CALL COQ3GR(XE,XDDL,GRADI,WORK)
  891. MPTVAL=IVAGRA
  892. DO i=1,NGRA
  893. MELVAL=IVAL(i)
  894. IBMN=MIN(IB,VELCHE(/2))
  895. VELCHE(1,IBMN)=GRADI(i)
  896. ENDDO
  897. ENDIF
  898. GOTO 100
  899. C= 2.14.6 - Elements DKT
  900. 28 IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  901. CALL VPAST(XE,BPSS)
  902. CALL VCORLC(XE,XEL,BPSS)
  903. CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  904. EPAIST=XZero
  905. MPTVAL=IVACAR
  906. IF (IVAL(1).NE.0) THEN
  907. MELVAL=IVAL(1)
  908. IBMN=MIN(IB,VELCHE(/2))
  909. DO iGau=1,NBPGAU
  910. IGMN=MIN(iGau,VELCHE(/1))
  911. EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  912. ENDDO
  913. EPAIST=EPAIST/NBPGAU
  914. ENDIF
  915. DO iGau=1,NBPGAU
  916. MPTVAL=IVACAR
  917. MELVAL=IVAL(2)
  918. IF (MELVAL.NE.0) THEN
  919. IBMN=MIN(IB,VELCHE(/2))
  920. EXCEN=VELCHE(1,IBMN)
  921. ELSE
  922. EXCEN=XZero
  923. ENDIF
  924. CALL BGRMAS(iGau,MELE,NBNO,LRE,IFOUR,NGRA,0,XEL,
  925. . EXCEN,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  926. CALL BGRDEP(BGR,NGRA,XDDLOC,LRE,GRADI)
  927. MPTVAL=IVAGRA
  928. DO i=1,NGRA
  929. MELVAL=IVAL(i)
  930. IGMN=MIN(iGau,VELCHE(/1))
  931. IBMN=MIN(IB,VELCHE(/2))
  932. VELCHE(IGMN,IBMN)=GRADI(i)
  933. ENDDO
  934. ENDDO
  935. GOTO 100
  936. C= 2.14.7 - Elements COQ8 et COQ6
  937. 41 IF (IB.EQ.1) THEN
  938. SEGINI,MWRK3
  939. MINTE1=IPMIN1
  940. SEGACT,MINTE1
  941. ENDIF
  942. C= Recuperation de l'epaisseur et des excentrements
  943. MPTVAL=IVACAR
  944. EPAIST=XZero
  945. MELVAL=IVAL(1)
  946. IF (MELVAL.NE.0) THEN
  947. IBMN=MIN(IB,VELCHE(/2))
  948. DO iGau=1,NBPGAU
  949. IGMN=MIN(iGau,VELCHE(/1))
  950. EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  951. ENDDO
  952. EPAIST=EPAIST/NBPGAU
  953. ENDIF
  954. EXCEN=XZero
  955. MELVAL=IVAL(2)
  956. IF (MELVAL.NE.0) THEN
  957. IBMN=MIN(IB,VELCHE(/2))
  958. DO iGau=1,NBPGAU
  959. IGMN=MIN(iGau,VELCHE(/1))
  960. EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  961. ENDDO
  962. EXCEN=EXCEN/NBPGAU
  963. ENDIF
  964. C= Element thermique
  965. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  966. CALL CQTGR2(XE,NBNN,NBPGAU,LRE,EPAIST,DZEGAU,
  967. . SHPTOT,MINTE1.SHPTOT,XDDL,WORK(1),WORK(1+LRE))
  968. IE=LRE
  969. C= Element mecanique
  970. ELSE
  971. CALL CQ8GRA(XE,NBNO,NBPGAU,LRE,EPAIST,EXCEN,DZEGAU,
  972. . SHPTOT,MINTE1.SHPTOT,XDDL,WORK,IRR)
  973. IE=0
  974. ENDIF
  975. MPTVAL=IVAGRA
  976. DO iGau=1,NBPGAU
  977. DO i=1,NGRA
  978. MELVAL=IVAL(i)
  979. IGMN=MIN(iGau,VELCHE(/1))
  980. IBMN=MIN(IB,VELCHE(/2))
  981. IE=IE+1
  982. VELCHE(IGMN,IBMN)=WORK(IE)
  983. ENDDO
  984. ENDDO
  985. GOTO 100
  986.  
  987. C= 2.14.8 - Element COQ2
  988. 44 IF (IB.EQ.1) SEGINI,MWRK2
  989. C= Element thermique
  990. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  991. ISDJC=0
  992. DO iGau=1,NBPGAU
  993. CALL CQTGR1(iGau,MELE,NBNN,LRE,IFOUR,NGRA,XE,SHPTOT,
  994. . XDDL,SHPWRK,BGR,DJAC,GRADI)
  995. IF (IERR.NE.0) GOTO 260
  996. IF (DJAC.EQ.XZero) THEN
  997. iMess=259
  998. GOTO 260
  999. ENDIF
  1000. MPTVAL=IVAGRA
  1001. DO i=1,NGRA
  1002. MELVAL=IVAL(i)
  1003. IGMN=MIN(iGau,VELCHE(/1))
  1004. IBMN=MIN(IB,VELCHE(/2))
  1005. VELCHE(IGMN,IBMN)=GRADI(i)
  1006. ENDDO
  1007. ENDDO
  1008. C= Element mecanique
  1009. ELSE
  1010. MPTVAL=IVACAR
  1011. IF (IVAL(1).NE.0) THEN
  1012. MELVAL=IVAL(1)
  1013. IBMN=MIN(IB,VELCHE(/2))
  1014. EPAIST=VELCHE(1,IBMN)
  1015. ELSE
  1016. EPAIST=XZero
  1017. ENDIF
  1018. DO iGau=1,NBPGAU
  1019. CALL BGRCQ2(BGR,DJAC,iGau,IFOUR,XE,NIFOUR,
  1020. . QSIGAU,POIGAU,IERT)
  1021. IF (IERT.NE.0) THEN
  1022. IF (IERT.EQ.1) iMess=255
  1023. IF (IERT.EQ.2) iMess=256
  1024. GOTO 260
  1025. ENDIF
  1026. CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  1027. MPTVAL=IVAGRA
  1028. DO i=1,NGRA
  1029. MELVAL=IVAL(i)
  1030. IGMN=MIN(iGau,VELCHE(/1))
  1031. IBMN=MIN(IB,VELCHE(/2))
  1032. VELCHE(IGMN,IBMN)=GRADI(i)
  1033. ENDDO
  1034. ENDDO
  1035. ENDIF
  1036. GOTO 100
  1037.  
  1038. C= 2.14.9 - Element COQ4
  1039. 49 MPTVAL=IVACAR
  1040. MELVAL=IVAL(1)
  1041. IF (MELVAL.NE.0) THEN
  1042. IBMN=MIN(IB,VELCHE(/2))
  1043. EPAIST=VELCHE(1,IBMN)
  1044. ELSE
  1045. EPAIST=XZero
  1046. ENDIF
  1047. MELVAL=IVAL(2)
  1048. IF (MELVAL.NE.0) THEN
  1049. IBMN=MIN(IB,VELCHE(/2))
  1050. EXCEN=VELCHE(1,IBMN)
  1051. ELSE
  1052. EXCEN=XZero
  1053. ENDIF
  1054. C= Element thermique
  1055. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1056. IF (IB.EQ.1) THEN
  1057. SEGINI,MWRK3
  1058. MINTE1=IPMIN1
  1059. SEGACT,MINTE1
  1060. ENDIF
  1061. CALL CQTGR2(XE,NBNN,NBPGAU,LRE,EPAIST,DZEGAU,
  1062. . SHPTOT,MINTE1.SHPTOT,XDDL,WORK(1),WORK(1+LRE))
  1063. MPTVAL=IVAGRA
  1064. IE=LRE
  1065. DO iGau=1,NBPGAU
  1066. DO i=1,NGRA
  1067. MELVAL=IVAL(i)
  1068. IGMN=MIN(iGau,VELCHE(/1))
  1069. IBMN=MIN(IB,VELCHE(/2))
  1070. IE=IE+1
  1071. VELCHE(IGMN,IBMN)=WORK(IE)
  1072. ENDDO
  1073. ENDDO
  1074. C= Element mecanique
  1075. ELSE
  1076. IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  1077. CALL CQ4LOC(XE,XEL,BPSS,IERT,1)
  1078. IF (IERT.EQ.1) IG1=IB
  1079. IF (IERT.EQ.3) THEN
  1080. IERT=0
  1081. NOPLAN=1
  1082. ELSE
  1083. NOPLAN=0
  1084. ENDIF
  1085. CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  1086. DO iGau=1,NBPGAU
  1087. CALL BGRCQ4(iGau,XEL,SHPTOT,SHPWRK,BGR,DJAC,EXCEN,
  1088. . NOPLAN,IERT)
  1089. IF (IERT.EQ.1) THEN
  1090. iMess=321
  1091. GOTO 260
  1092. ENDIF
  1093. CALL BGRDEP(BGR,NGRA,XDDLOC,LRE,GRADI)
  1094. MPTVAL=IVAGRA
  1095. DO i=1,NGRA
  1096. MELVAL=IVAL(i)
  1097. IGMN=MIN(iGau,VELCHE(/1))
  1098. IBMN=MIN(IB,VELCHE(/2))
  1099. VELCHE(IGMN,IBMN)=GRADI(i)
  1100. ENDDO
  1101. ENDDO
  1102. ENDIF
  1103. GOTO 100
  1104. C= 2.14.10 - Element DST
  1105. 93 IF (IB.EQ.1) THEN
  1106. NV1=NMATT
  1107. SEGINI,MWRK2,MWRK3,MWRK4,MVELCH
  1108. ENDIF
  1109. CALL VPAST(XE,BPSS)
  1110. CALL VCORLC(XE,XEL,BPSS)
  1111. CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  1112. C= Calcul de la moyenne des epaisseurs
  1113. MPTVAL=IVACAR
  1114. EPAIST=XZero
  1115. MELVAL=IVAL(1)
  1116. IF (MELVAL.NE.0) THEN
  1117. IBMN=MIN(IB,VELCHE(/2))
  1118. DO iGau=1,NBPGAU
  1119. IGMN=MIN(iGau,VELCHE(/1))
  1120. EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  1121. ENDDO
  1122. EPAIST=EPAIST/NBPGAU
  1123. ENDIF
  1124. C= Calcul de la moyenne des excentrements
  1125. EXCEN=XZero
  1126. MELVAL=IVAL(2)
  1127. IF (MELVAL.NE.0) THEN
  1128. IBMN=MIN(IB,VELCHE(/2))
  1129. DO iGau=1,NBPGAU
  1130. IGMN=MIN(iGau,VELCHE(/1))
  1131. EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  1132. ENDDO
  1133. EXCEN=EXCEN/NBPGAU
  1134. ENDIF
  1135. DO iGau=1,NBPGAU
  1136. MPTVAL=IVAMAT
  1137. DO i=1,NMATT
  1138. IF (IVAL(i).NE.0) THEN
  1139. MELVAL=IVAL(i)
  1140. IGMN=MIN(iGau,VELCHE(/1))
  1141. IBMN=MIN(IB,VELCHE(/2))
  1142. VALMAT(i)=VELCHE(IGMN,IBMN)
  1143. ELSE
  1144. VALMAT(i)=XZero
  1145. ENDIF
  1146. ENDDO
  1147. IF (iGau.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  1148. CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD1)
  1149. IF (IRTD1.EQ.0) GOTO 260
  1150. ENDIF
  1151. CALL HOOKMU(EPAIST,XZero,LHOOK,DDHOOK,DDHOMU)
  1152. CALL ZERO(BGR,NGRA,LRE)
  1153. C= Termes de la matrice BGR relatifs aux cisaillements transverses
  1154. CALL DSTGR2(XEL,NGRA,NSTRS,DDHOMU,WORK(1),WORK(10),
  1155. . WORK(19),BGR)
  1156. C= Termes de la matrice BGR relatifs aux effets de membrane
  1157. CALL DSTGR1(iGau,NBNO,XEL,NGRA,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1158. . EXCEN,WORK(1),WORK(10),WORK(19),BGR,DJAC)
  1159. C= Multiplication de BGR par les deplacements XDDLOC
  1160. CALL BGRDEP(BGR,NGRA,XDDLOC,LRE,GRADI)
  1161. MPTVAL=IVAGRA
  1162. DO i=1,NGRA
  1163. MELVAL=IVAL(i)
  1164. IGMN=MIN(iGau,VELCHE(/1))
  1165. IBMN=MIN(IB,VELCHE(/2))
  1166. VELCHE(IGMN,IBMN)=GRADI(i)
  1167. EnDDO
  1168. ENDDO
  1169. GOTO 100
  1170. C= 2.14.29 - ElementS POUTRE, TUYA, TIMO
  1171. 29 IF (IB.EQ.1) THEN
  1172. SEGINI,MWRK2
  1173. SEGINI,MWRK3
  1174. ENDIF
  1175. C= Element thermique
  1176. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1177. IMESS = 86
  1178. GOTO 260
  1179. C= Element mecanique
  1180. ELSE
  1181. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  1182. CALL ZERO(WORK,NCAR,1)
  1183. DO 4029 IGAU=1,NBNN
  1184. MPTVAL=IVACAR
  1185. DO 6029 IC=1,NCAR
  1186. IF (IVAL(IC).NE.0) THEN
  1187. MELVAL=IVAL(IC)
  1188. IBMN=MIN(IB ,VELCHE(/2))
  1189. IGMN=MIN(IGAU,VELCHE(/1))
  1190. IF (IGMN.GT.0.AND.IBMN.GT.0) THEN
  1191. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  1192. ELSE
  1193. WORK(IC)=0.
  1194. ENDIF
  1195. ELSE
  1196. WORK(IC)=0.
  1197. ENDIF
  1198. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  1199. 6029 CONTINUE
  1200. 4029 CONTINUE
  1201. C CAS OU ON A LU LE MOT VECTEUR
  1202. IF (IFOUR.EQ.2) THEN
  1203. IF (IVECT.EQ.1) THEN
  1204. IF (IVAL(NCAR).NE.0) THEN
  1205. MELVAL=IVAL(NCAR)
  1206. IBMN=MIN(IB,IELCHE(/2))
  1207. IP=IELCHE(1,IBMN)
  1208. IREF=(IP-1)*(IDIM+1)
  1209. DO 6129 IC=1,IDIM
  1210. WORK(NCAR+IC-1)=XCOOR(IREF+IC)
  1211. 6129 CONTINUE
  1212. ELSE
  1213. DO 6229 IC=1,IDIM
  1214. WORK(NCAR+IC-1)=0.D0
  1215. 6229 CONTINUE
  1216. ENDIF
  1217. ENDIF
  1218. ENDIF
  1219. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  1220. C EQUIVALENTE
  1221. IF (MELE.EQ.42) THEN
  1222. CISA=WORK(4)
  1223. VX=WORK(5)
  1224. VY=WORK(6)
  1225. VZ=WORK(7)
  1226. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  1227. ENDIF
  1228. C ON CALCULE LES GRADIENTS
  1229. IF (MELE.EQ.84) THEN
  1230. IF (CMATE.EQ.'SECTION') THEN
  1231. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1232. CALL TIMGR2(XE,XDDL,WORK(12),WORK(25))
  1233. ELSE
  1234. CALL TIMGR1(XE,XDDL,WORK(1),WORK(12),WORK(25))
  1235. ENDIF
  1236. ELSE
  1237. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1238. CALL TIMGR2(XE,XDDL,WORK(12),WORK(25))
  1239. ELSE
  1240. CALL TIMGR1(XE,XDDL,WORK(7),WORK(12),WORK(25))
  1241. ENDIF
  1242. ENDIF
  1243. ELSE
  1244. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1245. CALL POUGR2(XE,XDDL,WORK,WORK(12),WORK(25))
  1246. ELSE
  1247. CALL POUGR1(XE,XDDL,WORK,WORK(12),WORK(25))
  1248. ENDIF
  1249. ENDIF
  1250. C REMPLISSAGE
  1251. DO iGau=1,NBPGAU
  1252. MPTVAL=IVAGRA
  1253. DO i=1,NGRA
  1254. MELVAL=IVAL(i)
  1255. IGMN=MIN(iGau,VELCHE(/1))
  1256. IBMN=MIN(IB,VELCHE(/2))
  1257. IDECA=11+I+(IGAU-1)*NGRA
  1258. VELCHE(IGMN,IBMN)=WORK(IDECA)
  1259. ENDDO
  1260. ENDDO
  1261. ENDIF
  1262. GOTO 100
  1263. C
  1264. C ELEMENT JOI2
  1265. C
  1266. 85 IF (IB.EQ.1) THEN
  1267. SEGINI,MWRK2
  1268. SEGINI,MWRK4
  1269. ENDIF
  1270. C= Element thermique
  1271. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1272. IMESS = 86
  1273. GO TO 260
  1274. C= Element mecanique
  1275. ELSE
  1276. C
  1277. CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1278. C
  1279. C BOUCLE SUR LES POINTS DE GAUSS
  1280. C
  1281. DO 4085 IGAU=1,NBPGAU
  1282. C
  1283. CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1284. . BGR,DJAC,IRRT)
  1285. C IRRT.NE.0 JACOBIEN <= 0
  1286. IF(IRRT.NE.0) THEN
  1287. INTERR(1)=IB
  1288. IMESS=612
  1289. GOTO 260
  1290. ENDIF
  1291. C
  1292. CALL BST(BGR,XDDL,LRE,NSTRS,GRADI)
  1293. C
  1294. C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS
  1295. C
  1296. MPTVAL=IVAGRA
  1297. DO 9085 ICOMP=1,NGRA
  1298. MELVAL=IVAL(ICOMP)
  1299. IGMN=MIN(IGAU,VELCHE(/1))
  1300. IBMN=MIN(IB ,VELCHE(/2))
  1301. VELCHE(IGMN,IBMN)=GRADI(ICOMP)
  1302. 9085 CONTINUE
  1303. 4085 CONTINUE
  1304. C
  1305. ENDIF
  1306. GOTO 100
  1307. C
  1308. C ELEMENT JOI4
  1309. C
  1310. 88 IF (IB.EQ.1) THEN
  1311. SEGINI,MWRK2
  1312. SEGINI,MWRK4
  1313. ENDIF
  1314. C= Element thermique
  1315. IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1316. IMESS = 86
  1317. GO TO 260
  1318. C= Element mecanique
  1319. ELSE
  1320.  
  1321. C
  1322. CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1323. C
  1324. C BOUCLE SUR LES POINTS DE GAUSS
  1325. C
  1326. DO 4088 IGAU=1,NBPGAU
  1327. C
  1328. CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGR,DJAC,IRRT)
  1329. C IRRT.NE.0 JACOBIEN <= 0
  1330. IF (IRRT.NE.0) THEN
  1331. INTERR(1)=IB
  1332. IMESS = 611
  1333. GOTO 260
  1334. ENDIF
  1335. C
  1336. CALL BST(BGR,XDDL,LRE,NGRA,GRADI)
  1337. C
  1338. C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS
  1339. C
  1340. MPTVAL=IVAGRA
  1341. DO 9088 ICOMP=1,NGRA
  1342. MELVAL=IVAL(ICOMP)
  1343. IGMN=MIN(IGAU,VELCHE(/1))
  1344. IBMN=MIN(IB ,VELCHE(/2))
  1345. VELCHE(IGMN,IBMN)=GRADI(ICOMP)
  1346. 9088 CONTINUE
  1347. 4088 CONTINUE
  1348. C
  1349. ENDIF
  1350. GOTO 100
  1351.  
  1352. C= 2.14.265 - JOINT UNIDIMENSIONNEL JOI1
  1353. 265 SEGINI,MWRK2
  1354. SEGINI,MWRK3
  1355. SEGINI,MWRK4
  1356. C
  1357. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  1358. C
  1359. MPTVAL=IVAMAT
  1360. DO IC=1,NMATT
  1361. IF(IVAL(IC).NE.0) THEN
  1362. MELVAL=IVAL(IC)
  1363. IBMN=MIN(IB,VELCHE(/2))
  1364. WORK(IC)=VELCHE(1,IBMN)
  1365. ELSE
  1366. WORK(IC)=0.D0
  1367. ENDIF
  1368. END DO
  1369. C
  1370. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1371. C
  1372. C CALCUL DES DEPLACEMENTS LOCAUX
  1373. C
  1374. IAW1 = 101
  1375. IAW2 = IAW1 + LRE
  1376. CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1377. *
  1378. C ON CALCULE LES GRADIENTS
  1379. *
  1380. CALL JOIGR1(XDDL,WORK,LRE,NGRA,IDIM)
  1381. C REMPLISSAGE
  1382. DO iGau=1,NBPGAU
  1383. MPTVAL=IVAGRA
  1384. DO i=1,NGRA
  1385. MELVAL=IVAL(i)
  1386. IGMN=MIN(iGau,VELCHE(/1))
  1387. IBMN=MIN(IB,VELCHE(/2))
  1388. * IDECA=11+I+(IGAU-1)*NGRA
  1389. VELCHE(IGMN,IBMN)=WORK(I)
  1390. ENDDO
  1391. ENDDO
  1392. GOTO 100
  1393.  
  1394. C= 2.14.266 - Element ZCO2
  1395. 266 CONTINUE
  1396. IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  1397. DO 2660 iGau=1,NBPGAU
  1398. C MATRICE JACOBIENNE
  1399. DO I=1,NBNO
  1400. SHPWRK(1,I) = SHPTOT(1,I,IGAU)
  1401. SHPWRK(2,I) = SHPTOT(2,I,IGAU)
  1402. ENDDO
  1403. C TRAITEMENT PARTICULIER POUR LE CAS 2D
  1404. C SINON, APPEL A DEVOLU
  1405. IF(IDIM.EQ.2) THEN
  1406. dXdQsi=0.D0
  1407. dYdQsi=0.D0
  1408. DO i=1,NBNO
  1409. dXdQsi=dXdQsi+SHPWRK(2,i)*XE(1,i)
  1410. dYdQsi=dYdQsi+SHPWRK(2,i)*XE(2,i)
  1411. ENDDO
  1412. DJAC=SQRT(dXdQsi*dXdQsi+dYdQsi*dYdQsi)
  1413. C ON MULTIPLIE PAR LE RAYON EN AXI
  1414. IF (IFOUR.EQ.0) THEN
  1415. RAYON=0.D0
  1416. DO IRAY=1,NBNO
  1417. RAYON=RAYON+SHPTOT(1,IRAY,IGAU)*XE(1,IRAY)
  1418. ENDDO
  1419. DJAC=DJAC*RAYON
  1420. ENDIF
  1421. ELSE
  1422. * write(ioimp,*) 'option 3d non implementee'
  1423. GOTO 260
  1424. * CALL DEVOLU(XE,SHPWRK,MFR,NBNO,IFOUR,NIFOUR,IDIM,1.D0,RR,DJAC)
  1425. ENDIF
  1426. IF (DJAC.LT.XZero) ISDJC=ISDJC+1
  1427. IF (DJAC.EQ.XZero) THEN
  1428. iMess=259
  1429. GOTO 260
  1430. ENDIF
  1431. c passage Ni,qsi -> Ni,x
  1432. dQsidX = 0.d0
  1433. dQsidY = 0.d0
  1434. if((abs(dXdQsi)).gt.XPETIT) dQsidX = 1.d0/dXdQsi
  1435. if((abs(dYdQsi)).gt.XPETIT) dQsidY = 1.d0/dYdQsi
  1436. IF(IDIM.EQ.3) THEN
  1437. dQsidZ = 0.d0
  1438. if(abs(dZdQsi).gt.XPETIT) dQsidZ = 1.d0/dZdQsi
  1439. ENDIF
  1440. CALL ZERO(BGR,NGRA,LRE)
  1441. c on boucle sur les NGRA(=idim*idim) ligne :
  1442. c IGRA2 permet de remplir 1 sur idim
  1443. IGRA2=1
  1444. DO iidim = 1,idim
  1445. c on boucle sur les idim*NBNO colonnes :
  1446. c II permet de remplir 1 sur idim
  1447. DO I=1,NBNO
  1448. II = idim*(I-1) + iidim
  1449. BGR(IGRA2 ,II) = SHPWRK(2,I)*dQsidX
  1450. BGR(IGRA2+1,II) = SHPWRK(2,I)*dQsidY
  1451. if(idim.eq.3) BGR(IGRA2+2,II) = SHPWRK(2,I)*dQsidZ
  1452. ENDDO
  1453. IGRA2=IGRA2+idim
  1454. ENDDO
  1455. c {grad u}_i = [Bij] * {u_j}
  1456. CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  1457. c on remplit
  1458. MPTVAL=IVAGRA
  1459. DO i=1,NGRA
  1460. MELVAL=IVAL(i)
  1461. IGMN=MIN(iGau,VELCHE(/1))
  1462. IBMN=MIN(IB,VELCHE(/2))
  1463. VELCHE(IGMN,IBMN)=GRADI(i)
  1464. ENDDO
  1465. 2660 CONTINUE
  1466. GOTO 100
  1467.  
  1468. C= 4.14.267 - Element ZCO3
  1469. 267 CONTINUE
  1470. IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  1471. DO 2670 iGau=1,NBPGAU
  1472. C MATRICE JACOBIENNE
  1473. DO I=1,NBNO
  1474. SHPWRK(1,I) = SHPTOT(1,I,IGAU)
  1475. SHPWRK(2,I) = SHPTOT(2,I,IGAU)
  1476. SHPWRK(3,I) = SHPTOT(3,I,IGAU)
  1477. ENDDO
  1478. c write(6,*) 'SHPWRK(2,I) = ' ,(SHPWRK(2,iou),iou=1,NBNO)
  1479. c write(6,*) 'SHPWRK(3,I) = ' ,(SHPWRK(3,iou),iou=1,NBNO)
  1480.  
  1481.  
  1482. dXdQsi=0.D0
  1483. dXdEta=0.D0
  1484. dYdQsi=0.D0
  1485. dYdEta=0.D0
  1486. dZdQsi=0.D0
  1487. dZdEta=0.D0
  1488. DO i=1,NBNO
  1489. dXdQsi=dXdQsi+SHPWRK(2,i)*XE(1,i)
  1490. dXdEta=dXdEta+SHPWRK(3,i)*XE(1,i)
  1491. dYdQsi=dYdQsi+SHPWRK(2,i)*XE(2,i)
  1492. dYdEta=dYdEta+SHPWRK(3,i)*XE(2,i)
  1493. dZdQsi=dYdQsi+SHPWRK(2,i)*XE(3,i)
  1494. dZdEta=dZdEta+SHPWRK(3,i)*XE(3,i)
  1495. ENDDO
  1496.  
  1497. c write(6,*)' dXdQsi = ',dXdQsi
  1498. c write(6,*)' dYdQsi = ',dYdQsi
  1499. c write(6,*)' dZdQsi = ',dZdQsi
  1500. c write(6,*)' dXdEta = ',dXdEta
  1501. c write(6,*)' dYdEta = ',dYdEta
  1502. c write(6,*)' dZdEta = ',dZdEta
  1503. C définition des vecteurs de la base orthonormé
  1504. c vQsi
  1505. vQsi = sqrt(dXdQsi*dXdQsi+dYdQsi*dYdQsi+dZdQsi*dZdQsi)
  1506. c write(6,*) 'Norme de vQsi = ',vQsi
  1507. vQsiX = dXdQsi / vQsi
  1508. vQsiY = dYdQsi / vQsi
  1509. vQsiZ = dZdQsi / vQsi
  1510. c write(6,*) ' vQsiX = ', vQsiX
  1511. c write(6,*) ' vQsiY = ', vQsiY
  1512. c write(6,*) ' vQsiZ = ', vQsiZ
  1513.  
  1514. c produit scalaire VEta vQsi
  1515. Sca1 = dXdEta*vQsiX + dYdEta*vQsiY + dZdEta*vQsiZ
  1516. c write(6,*) 'VEta.vQsi = ',Sca1
  1517. c EEta = Veta - sca1 Eqsi (orthogonalisation)
  1518. vEtaX = dXdEta - sca1 * vQsiX
  1519. vEtaY = dYdEta - sca1 * vQsiY
  1520. vEtaZ = dZdEta - sca1 * vQsiZ
  1521. c write(6,*) ' vEtaX = ', vEtaX
  1522. c write(6,*) ' vEtaY = ', vEtaY
  1523. c write(6,*) ' vEtaZ = ', vEtaZ
  1524. c on morme EEta
  1525. vEta = sqrt(vEtaX*vEtaX+vEtaY*vEtaY+vEtaZ*vEtaZ)
  1526. c write(6,*) 'Norme de vEta = ',veta
  1527. vEtaX = vEtaX / vEta
  1528. vEtaY = vEtaY / vEta
  1529. vEtaZ = vEtaZ / vEta
  1530.  
  1531. c Qsi,x
  1532. dQsidX=0.D0
  1533. dQsidY=0.D0
  1534. dQsidZ=0.D0
  1535. dEtadX=0.D0
  1536. dEtadY=0.D0
  1537. dEtadZ=0.D0
  1538. dQsidX=(vQsiX - (sca1*vEtaX)/vEta)/vQsi
  1539. dQsidY=(vQsiY - (sca1*vEtaY)/vEta)/vQsi
  1540. dQsidZ=(vQsiZ - (sca1*vEtaZ)/vEta)/vQsi
  1541. dEtadX=vEtaX/vEta
  1542. dEtadY=vEtaY/vEta
  1543. dEtadZ=vEtaZ/vEta
  1544.  
  1545. c write(6,*)' dQsidX = ',dQsidX
  1546. c write(6,*)' dQsidY = ',dQsidY
  1547. c write(6,*)' dQsidZ = ',dQsidZ
  1548. c write(6,*)' dEtadX = ',dEtadX
  1549. c write(6,*)' dEtadY = ',dEtadY
  1550. c write(6,*)' dEtadZ = ',dEtadZ
  1551.  
  1552. c write(6,*) 'SHPWRK(1,I) = ' ,(SHPWRK(1,iou),iou=1,NBNO)
  1553. c write(6,*) 'SHPWRK(2,I) = ' ,(SHPWRK(2,iou),iou=1,NBNO)
  1554. c write(6,*) 'SHPWRK(3,I) = ' ,(SHPWRK(3,iou),iou=1,NBNO)
  1555.  
  1556. CALL ZERO(BGR,NGRA,LRE)
  1557. c on boucle sur les NGRA(=idim*idim) ligne :
  1558. c IGRA2 permet de remplir 1 sur idim
  1559. IGRA2=1
  1560. DO iidim = 1,idim
  1561. c on boucle sur les idim*NBNO colonnes :
  1562. c II permet de remplir 1 sur idim
  1563. DO I=1,NBNO
  1564. II = idim*(I-1) + iidim
  1565. BGR(IGRA2 ,II) = SHPWRK(2,I)*dQsidX+SHPWRK(3,I)*dEtadX
  1566. BGR(IGRA2+1,II) = SHPWRK(2,I)*dQsidY+SHPWRK(3,I)*dEtadY
  1567. if(idim.eq.3) then
  1568. BGR(IGRA2+2,II) = SHPWRK(2,I)*dQsidZ+SHPWRK(3,I)*dEtadZ
  1569. endif
  1570. ENDDO
  1571. IGRA2=IGRA2+idim
  1572. ENDDO
  1573. c {grad u}_i = [Bij] * {u_j}
  1574. c DO I=1,NGRA
  1575. c write(6,*) 'BGR(',I,',..) = ' ,(BGR(I,iou),iou=1,idim*NBNO)
  1576. c write(6,*) 'BGR(2,I) = ' ,(BGR(2,iou),iou=1,idim*NBNO)
  1577. c write(6,*) 'BGR(3,I) = ' ,(BGR(3,iou),iou=1,idim*NBNO)
  1578. c ENDDO
  1579.  
  1580. CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  1581. c write(6,*) 'XDDL(i) = ' ,(XDDL(iou),iou=1,LRE)
  1582. c write(6,*) 'GRADI(i) = ' ,(GRADI(iou),iou=1,NGRA)
  1583. c on remplit
  1584. MPTVAL=IVAGRA
  1585. DO i=1,NGRA
  1586. MELVAL=IVAL(i)
  1587. IGMN=MIN(iGau,VELCHE(/1))
  1588. IBMN=MIN(IB,VELCHE(/2))
  1589. VELCHE(IGMN,IBMN)=GRADI(i)
  1590. ENDDO
  1591.  
  1592. 2670 CONTINUE
  1593. GOTO 100
  1594.  
  1595.  
  1596. 100 CONTINUE
  1597.  
  1598.  
  1599.  
  1600. IF (ITHEHY.NE.0) SEGSUP,MLREE1,MLREE2
  1601. C= Fin de la boucle sur les elements
  1602. iOK=1
  1603. C ======
  1604. C 2.15 - Desactivation/suppression de segments associes a iSou
  1605. C ======
  1606. 260 IF (MWRK2.NE.0) SEGSUP,MWRK2
  1607. IF (MWRK3.NE.0) SEGSUP,MWRK3
  1608. IF (MWRK4.NE.0) SEGSUP,MWRK4
  1609. IF (MVELCH.NE.0) SEGSUP,MVELCH
  1610. IF (IPMIN1.NE.0) SEGDES,MINTE1
  1611. 250 CONTINUE
  1612. SEGSUP,MWRK1
  1613. NOMID=MOGRAD
  1614. if(lsupgd)SEGSUP,NOMID
  1615. 240 NOMID=MODEPL
  1616. if(lsupdp)SEGSUP,NOMID
  1617. CALL DTMVAL(IVADEP,1)
  1618. 230 IF (MOMATR.NE.0) THEN
  1619. NOMID=MOMATR
  1620. SEGSUP,NOMID
  1621. ENDIF
  1622. CALL DTMVAL(IVAMAT,1)
  1623. 220 IF (MOCARA.NE.0) THEN
  1624. NOMID=MOCARA
  1625. SEGSUP,NOMID
  1626. ENDIF
  1627. CALL DTMVAL(IVACAR,1)
  1628. SEGDES,MINTE
  1629. 210 CONTINUE
  1630. SEGDES,MELEME
  1631. 200 CONTINUE
  1632. SEGDES,IMODEL
  1633. C= Sortie prematuree en cas d'ERREUR (iOK=0)
  1634. IF (iOK.EQ.0) THEN
  1635. CALL DTMVAL(IVAGRA,3)
  1636. IF (MCHAML.NE.0) SEGSUP,MCHAML
  1637. SEGSUP,MCHELM
  1638. IF (iMess.NE.0) THEN
  1639. INTERR(1)=IB
  1640. CALL ERREUR(iMess)
  1641. ENDIF
  1642. GOTO 300
  1643. ENDIF
  1644. MPTVAL = IVAGRA
  1645. DO i = 1, IVAL(/1)
  1646. MELVAL = IVAL(i)
  1647. CALL COMRED(MELVAL)
  1648. ENDDO
  1649. CALL DTMVAL(IVAGRA,1)
  1650. SEGDES,MCHAML
  1651. 2000 continue
  1652.  
  1653. C 3 - MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
  1654. C ====================================================
  1655. IRET=1
  1656. if( n1.ne.isouss) then
  1657. n1=isouss
  1658. segadj mchelm
  1659. endif
  1660. SEGDES,MCHELM
  1661. 300 CONTINUE
  1662. SEGDES,MMODEL
  1663. NOTYPE=MOTYCH
  1664. SEGSUP,NOTYPE
  1665. C* IF (IPCHE1.NE.0) THEN
  1666. C* MCHELM=IPCHE1
  1667. C* SEGDES,MCHELM
  1668. C* ENDIF
  1669. C* IF (IPCHE2.NE.0) THEN
  1670. C* MCHELM=IPCHE2
  1671. C* SEGDES,MCHELM
  1672. C* ENDIF
  1673.  
  1674. RETURN
  1675. END
  1676.  
  1677.  
  1678.  
  1679.  
  1680.  

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