Télécharger grad1.eso

Retour à la liste

Numérotation des lignes :

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

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