Télécharger grad1.eso

Retour à la liste

Numérotation des lignes :

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

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