Télécharger grad1.eso

Retour à la liste

Numérotation des lignes :

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

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