Télécharger graf1.eso

Retour à la liste

Numérotation des lignes :

  1. C GRAF1 SOURCE CB215821 17/01/16 21:15:31 9279
  2. SUBROUTINE GRAF1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *____________________________________________________________________*
  6. * *
  7. * Sous-programme de l'op{rateur GRADIENT DE FLEXION *
  8. * *
  9. * Entr{es: *
  10. * *
  11. * IPMODL Pointeur sur un objet MMODEL *
  12. * IPCHE2 Pointeur sur un MCHAML de DEPLACEMENT *
  13. * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES *
  14. * *
  15. * Sortie: *
  16. * *
  17. * IPCHL1 Pointeur sur un MCHAML de gradients *
  18. * IRET 1 si succes , 0 sinon *
  19. * *
  20. * Auteurs, date de cr{ation: *
  21. * *
  22. * SUO X.Z Le 19/21/1986 *
  23. * Passage aux nouveux chamelems par P.DOWLATYARI le 28/03/91 *
  24. * *
  25. *____________________________________________________________________*
  26. *
  27. -INC CCOPTIO
  28. -INC CCHAMP
  29. -INC SMCHAML
  30. -INC SMMODEL
  31. -INC SMELEME
  32. -INC SMINTE
  33. -INC SMCOORD
  34. *
  35. SEGMENT,MWRK1
  36. REAL*8 XDDL(LRE),XE(3,NBBB),GRADF(NGRAF)
  37. REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS)
  38. ENDSEGMENT
  39. *
  40. SEGMENT,MWRK2
  41. REAL*8 SHPWRK(6,NBNO),BGF(NGRAF,LRE)
  42. ENDSEGMENT
  43. *
  44. SEGMENT,MWRK3
  45. REAL*8 WORK(LW)
  46. ENDSEGMENT
  47. *
  48. SEGMENT,MWRK4
  49. REAL*8 BPSS(3,3),XEL(3,NBBB),XDDLOC(LRE)
  50. ENDSEGMENT
  51. *
  52. SEGMENT NOTYPE
  53. CHARACTER*16 TYPE(NBTYPE)
  54. ENDSEGMENT
  55. *
  56. SEGMENT MVELCH
  57. REAL*8 VALMAT(NV1)
  58. ENDSEGMENT
  59. *
  60. SEGMENT MPTVAL
  61. INTEGER IPOS(NS) ,NSOF(NS)
  62. INTEGER IVAL(NCOSOU)
  63. CHARACTER*16 TYVAL(NCOSOU)
  64. ENDSEGMENT
  65. *
  66. CHARACTER*8 CMATE
  67. PARAMETER ( NINF=3 )
  68. INTEGER INFOS(NINF)
  69. CHARACTER*(NCONCH) CONM
  70. LOGICAL lsupgf,lsupdp
  71. *
  72. IRET=1
  73. MWRK1=0
  74. MWRK2=0
  75. MWRK3=0
  76. MWRK4=0
  77. MVELCH=0
  78. NMAT = 0
  79. IMESS= 0
  80. NHRM = NIFOUR
  81. *
  82. * ACTIVATION DU CHAPEAU DE MODELE
  83. *
  84. MMODEL = IPMODL
  85. SEGACT MMODEL
  86. NSOUS = KMODEL(/1)
  87. *
  88. * Initialisation du CHAMELEM de GRADIENTS DE FLEXION
  89. *
  90. L1 = 19
  91. N1 = NSOUS
  92. N3 = 6
  93. SEGINI,MCHELM
  94. IPCHL1=MCHELM
  95. TITCHE = 'GRADIENT DE FLEXION'
  96. IFOCHE=IFOUR
  97. *
  98. * Boucle sur les zones {l{mentaires du MODELE
  99. *
  100. DO 500 ISOUS=1,NSOUS
  101. *
  102. * QUELQUES INITIALISATIONS
  103. *
  104. NGRAF= 0
  105. MOGRAF=0
  106. MODEPL=0
  107. MOMATR=0
  108. MOCARA=0
  109. NDEP=0
  110. NCAR = 0
  111. IPMINT=0
  112. IRTD1=1
  113. NSTRS=0
  114. IVAGRF=0
  115. IVADEP=0
  116. IVAMAT=0
  117. IVACAR=0
  118. NMATR=0
  119. NMATF=0
  120. *
  121. IMODEL=KMODEL(ISOUS)
  122. SEGACT IMODEL
  123. MELE=NEFMOD
  124. IPMAIL=IMAMOD
  125. CONM=CONMOD
  126. NFOR=FORMOD(/2)
  127. NMAT=MATMOD(/2)
  128. CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  129. IF (CMATE.EQ.' ')THEN
  130. CALL ERREUR(251)
  131. SEGDES IMODEL,MMODEL
  132. SEGSUP MCHELM
  133. IRET=0
  134. RETURN
  135. ENDIF
  136. *
  137. * ACTIVATION DU MAILLAGE
  138. *
  139. MELEME=IPMAIL
  140. SEGACT,MELEME
  141. NBNN =NUM(/1)
  142. NBELEM=NUM(/2)
  143. NBNO=NBNN
  144. *
  145. * INFORMATIONS SUR L'ELEMENT FINI
  146. *
  147. * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  148. * IF (IERR.NE.0) THEN
  149. * SEGDES IMODEL,MMODEL
  150. * SEGSUP MCHELM
  151. * IRET=0
  152. * RETURN
  153. * ENDIF
  154. * INFO=IPINF
  155. MFR=INFELE(13)
  156. * MINTE=INFELE(11)
  157. minte=infmod(7)
  158. MINTE1= INFMOD(8)
  159. NSTRS =INFELE(16)
  160. LW = INFELE( 7)
  161. LRE = INFELE( 9)
  162. LHOOK =INFELE(10)
  163. *
  164. * ACTIVATION DU SEGMENT D'INTEGRATION
  165. *
  166. SEGACT,MINTE
  167. NBPGAU=POIGAU(/1)
  168. C
  169. C CREATION DU TABLEAU INFOS
  170. C
  171. CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
  172. IF (IRTD.EQ.0) GOTO 9990
  173. *
  174. * NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS
  175. *
  176. if(lnomid(11).ne.0) then
  177. nomid=lnomid(11)
  178. segact nomid
  179. mograf=nomid
  180. ngraf=lesobl(/2)
  181. nfac=lesfac(/2)
  182. lsupgf=.false.
  183. else
  184. lsupgf=.true.
  185. CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
  186. endif
  187. *
  188. * NOMS DE COMPOSANTES DU DEPLACEMENT
  189. *
  190. if(lnomid(1).ne.0) then
  191. nomid=lnomid(1)
  192. segact nomid
  193. modepl=nomid
  194. ndep=lesobl(/2)
  195. nfac=lesfac(/2)
  196. lsupdp=.false.
  197. else
  198. lsupdp=.true.
  199. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEP,NFAC)
  200. endif
  201. *
  202. * VERIFICATION DE PRESENCE DES COMPOSANTES
  203. *
  204. NBTYPE=1
  205. SEGINI NOTYPE
  206. MOTYPE=NOTYPE
  207. TYPE(1)='REAL*8'
  208. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MODEPL,
  209. 1 MOTYPE,1,INFOS,3,IVADEP)
  210. SEGSUP NOTYPE
  211. IF (IERR.NE.0) THEN
  212. NGRAF=0
  213. GO TO 9990
  214. ENDIF
  215. *
  216. * RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE
  217. * TRAVAIL UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST (MELE=93)
  218. *
  219. * CAS DES POUTRES ET TUYAUX : RECHERCHE DU VECTEUR LOCAL
  220. *
  221. NBROBL=0
  222. NBRFAC=0
  223. MOMATR=0
  224. MOCARA=0
  225. NCAR=0
  226. NMATR=0
  227. NMATF=0
  228. IVECT=0
  229. *
  230. *
  231. IF(MELE.EQ.93.AND.FORMOD(1).EQ.'MECANIQUE'
  232. 1 .AND.CMATE.EQ.'ISOTROPE') THEN
  233. NBROBL=2
  234. NBRFAC=0
  235. SEGINI NOMID
  236. MOMATR=NOMID
  237. LESOBL(1)='YOUN'
  238. LESOBL(2)='NU '
  239. NMATR=NBROBL
  240. NMATF=NBRFAC
  241. *
  242. IF (IPCHE1.NE.0) THEN
  243. NBTYPE=1
  244. SEGINI NOTYPE
  245. MOTYPE=NOTYPE
  246. TYPE(1)='REAL*8'
  247. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,
  248. 1 1,INFOS,3,IVAMAT)
  249. SEGSUP NOTYPE
  250. ELSE
  251. MOTERR(1:8)='CARACTER'
  252. MOTERR(9:12)=NOMTP(MELE)
  253. MOTERR(13:20)='GRAF'
  254. CALL ERREUR(145)
  255. NMATR=0
  256. NMATF=0
  257. NGRAF=0
  258. NOMID=MOMATR
  259. SEGSUP NOMID
  260. MOMATR=0
  261. GOTO 9990
  262. ENDIF
  263. IF (IERR.NE.0) GOTO 9990
  264. *
  265. NMATT=NMATR+NMATF
  266. *
  267. MPTVAL=IVAMAT
  268. NBGMAT = 0
  269. NELMAT = 0
  270. DO 1108 IM=1,NMATT
  271. IF(IVAL(IM).NE.0)THEN
  272. MELVAL=IVAL(IM)
  273. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  274. NELMAT=MAX(NELMAT,VELCHE(/2))
  275. ENDIF
  276. 1108 CONTINUE
  277. C
  278. NBROBL=1
  279. NBRFAC=1
  280. SEGINI NOMID
  281. MOCARA=NOMID
  282. LESOBL(1)='EPAI'
  283. LESFAC(1)='EXCE'
  284. NCAR=1
  285. NBTYPE=1
  286. SEGINI NOTYPE
  287. MOTYPE=NOTYPE
  288. TYPE(1)='REAL*8'
  289. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,
  290. 1 MOTYPE,1,INFOS,3,IVACAR)
  291. SEGSUP NOTYPE
  292. IF (IERR.NE.0) GOTO 9990
  293. ENDIF
  294. C
  295. IF(IVACAR.NE.0)THEN
  296. MPTVAL=IVACAR
  297. IPMELV=IVAL(1)
  298. CALL QUELCH(IPMELV,ICONS)
  299. IF(ICONS.NE.0)THEN
  300. CALL ERREUR(566)
  301. GOTO 9990
  302. ENDIF
  303. *
  304. * CAS DES POUTRES ET TUYAUX
  305. *
  306. ELSE IF(MFR.EQ.7) THEN
  307. IF (CMATE.EQ.'SECTION') THEN
  308. NBROBL=0
  309. NBRFAC=1
  310. SEGINI NOMID
  311. MOCARA=NOMID
  312. LESFAC(1)='VECT'
  313. IVECT=1
  314. *
  315. NBTYPE=1
  316. SEGINI NOTYPE
  317. TYPE(1)='POINTEURPOINT '
  318. ELSE
  319. IF(IFOUR.EQ.2) THEN
  320. NBROBL=4
  321. NBRFAC=3
  322. SEGINI NOMID
  323. MOCARA=NOMID
  324. LESOBL(1)='TORS'
  325. LESOBL(2)='INRY'
  326. LESOBL(3)='INRZ'
  327. LESOBL(4)='SECT'
  328. LESFAC(1)='SECY'
  329. LESFAC(2)='SECZ'
  330. LESFAC(3)='VECT'
  331. IVECT=1
  332. *
  333. NBTYPE=7
  334. SEGINI NOTYPE
  335. TYPE(1)='REAL*8'
  336. TYPE(2)='REAL*8'
  337. TYPE(3)='REAL*8'
  338. TYPE(4)='REAL*8'
  339. TYPE(5)='REAL*8'
  340. TYPE(6)='REAL*8'
  341. TYPE(7)='POINTEURPOINT '
  342. ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.63) THEN
  343. NBRFAC=1
  344. NBROBL=2
  345. SEGINI NOMID
  346. MOCARA=NOMID
  347. LESOBL(1)= 'SECT'
  348. LESOBL(2)= 'INRZ'
  349. LESFAC(1)= 'SECY'
  350. *
  351. NBTYPE=1
  352. SEGINI NOTYPE
  353. TYPE(1)='REAL*8'
  354. ENDIF
  355. ENDIF
  356. C
  357. C CARACTERISTIQUE POUR LES TUYAUX
  358. C
  359. ELSE IF (MFR.EQ.13) THEN
  360. NBROBL=2
  361. NBRFAC=3
  362. SEGINI NOMID
  363. MOCARA=NOMID
  364. LESOBL(1)='EPAI'
  365. LESOBL(2)='RAYO'
  366. LESFAC(1)='RACO'
  367. LESFAC(2)='CISA'
  368. LESFAC(3)='VECT'
  369. IVECT=1
  370. C
  371. NBTYPE=5
  372. SEGINI NOTYPE
  373. TYPE(1)='REAL*8'
  374. TYPE(2)='REAL*8'
  375. TYPE(3)='REAL*8'
  376. TYPE(4)='REAL*8'
  377. TYPE(5)='POINTEURPOINT '
  378. C
  379. ENDIF
  380. NCARA=NBROBL
  381. NCARF=NBRFAC
  382. NCAR=NBROBL+NBRFAC
  383.  
  384. C Verification de la presence des caracteristiques dans IPCHE1
  385.  
  386. IF (NCAR.NE.0) THEN
  387. IF (IPCHE1.NE.0) THEN
  388. MOTYPE=NOTYPE
  389. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  390. . INFOS,3,IVACAR)
  391. SEGSUP,NOTYPE
  392. IF(IERR.NE.0) GOTO 9990
  393. IF (IVACAR.NE.0) THEN
  394. MPTVAL=IVACAR
  395. IPMELV=IVAL(1)
  396. CALL QUELCH(IPMELV,ICONS)
  397. IF (ICONS.NE.0) THEN
  398. CALL ERREUR(566)
  399. GOTO 9990
  400. ENDIF
  401. ENDIF
  402. *
  403. * CAS DES POUTRES : TRAITEMENT DES VECTEURS
  404. IF (IVECT.EQ.1) THEN
  405. MPTVAL=IVACAR
  406. IF (IVAL(NCAR).EQ.0) THEN
  407. C
  408. C MOT CLE VECT EN CAS DE CONVERSION
  409. C
  410. segsup mptval
  411. IVECT=2
  412. NOMID=MOCARA
  413. C* SEGACT NOMID
  414. NBRFAC=NBRFAC+2
  415. SEGADJ NOMID
  416. LESFAC(NBRFAC-2)='VX '
  417. LESFAC(NBRFAC-1)='VY '
  418. LESFAC(NBRFAC) ='VZ '
  419. C
  420. NCARF=NBRFAC
  421. NCAR=NCARA+NCARF
  422. *
  423. NBTYPE=1
  424. SEGINI NOTYPE
  425. TYPE(1)='REAL*8'
  426. MOTYCH=NOTYPE
  427. C
  428. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYCH,
  429. $ 1,INFOS,3,IVACAR)
  430. SEGSUP,NOTYPE
  431. IF (IERR.NE.0) GOTO 9990
  432. ENDIF
  433. ENDIF
  434.  
  435.  
  436. ELSE
  437. SEGSUP,NOTYPE
  438. MOTERR(1:8)='CARACTER'
  439. MOTERR(9:12)=NOMTP(MELE)
  440. MOTERR(13:20)='GRAF'
  441. CALL ERREUR(145)
  442. GOTO 9990
  443. ENDIF
  444. ENDIF
  445. *
  446. C =====
  447. C Cas d'un joint unidimensionnel JOI1
  448. C Chargement des vecteurs stitués dans les caractéristiques matériau
  449. C =====
  450. IF(MFR.EQ.75) THEN
  451. IF(IDIM.EQ.3) THEN
  452. NBROBL=6
  453. NBRFAC=0
  454. SEGINI NOMID
  455. MOMATR=NOMID
  456. LESOBL(1)='V1X'
  457. LESOBL(2)='V1Y'
  458. LESOBL(3)='V1Z'
  459. LESOBL(4)='V2X'
  460. LESOBL(5)='V2Y'
  461. LESOBL(6)='V2Z'
  462. NMATR=NBROBL
  463. NMATF=NBRFAC
  464. ELSE IF(IDIM.EQ.2) THEN
  465. NBROBL=2
  466. NBRFAC=0
  467. SEGINI NOMID
  468. MOMATR=NOMID
  469. LESOBL(1)='V1X'
  470. LESOBL(2)='V1Y'
  471. NMATR=NBROBL
  472. NMATF=NBRFAC
  473. ENDIF
  474. NBTYPE=1
  475. SEGINI NOTYPE
  476. TYPE(1)='REAL*8'
  477. MOTYPE=NOTYPE
  478. *
  479. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  480. SEGSUP NOTYPE
  481. IF (IERR.NE.0) GOTO 9990
  482. *
  483. NMATT=NMATR+NMATF
  484. * C
  485. IF(ISUP1.EQ.1)THEN
  486. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  487. IF(IERR.NE.0)THEN
  488. ISUP1=0
  489. GOTO 9990
  490. ENDIF
  491. ENDIF
  492. MPTVAL=IVAMAT
  493. NBGMAT = 0
  494. NELMAT = 0
  495. DO 11265 IM=1,NMATT
  496. IF(IVAL(IM).NE.0)THEN
  497. MELVAL=IVAL(IM)
  498. IF (CMATE.EQ.'SECTION') THEN
  499. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  500. NELMAT=MAX(NELMAT,IELCHE(/2))
  501. ELSE
  502. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  503. NELMAT=MAX(NELMAT,VELCHE(/2))
  504. ENDIF
  505. ENDIF
  506. 11265 CONTINUE
  507. nmattd=nmatt
  508. ivamtd= ivamat
  509. segdes nomid
  510. ENDIF
  511. *
  512. * CREATION DU MCHAML DE GRADIENT DE FLEXION
  513. *
  514. N2=NGRAF
  515. SEGINI,MCHAML
  516. ICHAML(ISOUS)=MCHAML
  517. IMACHE(ISOUS)=MELEME
  518. CONCHE(ISOUS)=CONMOD
  519. *
  520. INFCHE(ISOUS,1)=0
  521. INFCHE(ISOUS,2)=0
  522. INFCHE(ISOUS,3)=NHRM
  523. INFCHE(ISOUS,4)=MINTE
  524. INFCHE(ISOUS,5)=0
  525. INFCHE(ISOUS,6)=5
  526. *
  527. * RECHERCHE DES DIMENSIONS LES PLUS GRANDES
  528. *
  529. N1EL=0
  530. N1PTEL=0
  531. MPTVAL=IVADEP
  532. DO 178 IO=1,NDEP
  533. MELVAL=IVAL(IO)
  534. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  535. N1EL =MAX(N1EL ,VELCHE(/2))
  536. 178 CONTINUE
  537. *
  538. IF(IVACAR.NE.0)THEN
  539. MPTVAL=IVACAR
  540. DO 179 IO=1,NCAR
  541. IF(IVAL(IO).NE.0) THEN
  542. MELVAL=IVAL(IO)
  543. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  544. N1EL =MAX(N1EL ,VELCHE(/2))
  545. ENDIF
  546. 179 CONTINUE
  547. ENDIF
  548. *
  549. IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  550. N1PTEL=1
  551. ELSE
  552. N1PTEL=NBPGAU
  553. ENDIF
  554. N1EL =MIN(N1EL ,NBELEM)
  555. *
  556. * CREATION DES MELVAL DU GRADIENT DE FLEXION
  557. *
  558. NS=1
  559. NCOSOU=NGRAF
  560. SEGINI MPTVAL
  561. IVAGRF=MPTVAL
  562. NOMID=MOGRAF
  563. SEGACT NOMID
  564. DO 77 IGR=1,NGRAF
  565. TYPCHE(IGR)='REAL*8'
  566. NOMCHE(IGR)=LESOBL(IGR)
  567. N2PTEL=0
  568. N2EL=0
  569. SEGINI MELVAL
  570. IELVAL(IGR)=MELVAL
  571. IVAL(IGR)=MELVAL
  572. 77 CONTINUE
  573. SEGDES NOMID
  574. *
  575. C=======================================================================
  576. C NUMERO DES ETIQUETTES :
  577. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  578. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  579. C 5 CONTINUE
  580. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  581. C 44 CONTINUE
  582. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  583. C=======================================================================
  584. GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  585. 1 99,99,99,99,99,99,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
  586. 2 99,29,99,44,99,99,99,99,49,99,99,99,99,99,99,99,99,99,99,99,
  587. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  588. 4 99,99,99,29,99,99,99,99,99,99,99,99,93,99,99,99,99),MELE
  589. C
  590. IF (MELE.EQ.265) GOTO 265
  591. 99 CONTINUE
  592. MOTERR(1:4)=NOMTP(MELE)
  593. MOTERR(9:12)='GRAF'
  594. IMESS = 86
  595. GOTO 9990
  596. *
  597. C ______________________
  598. C | ELEMENTS COQ3 |
  599. C |______________________|
  600. 27 CONTINUE
  601. NBBB=NBNN
  602. SEGINI MWRK1,MWRK3
  603. C
  604. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  605. C
  606. DO 3027 IB=1,NBELEM
  607. C
  608. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  609. C
  610. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  611. C
  612. C ON CHERCHE LES DEPLACEMENTS
  613. C
  614. IE=0
  615. MPTVAL=IVADEP
  616. DO 4027 IGAU=1,NBNN
  617. DO 4027 ICOMP=1,NDEP
  618. IE=IE+1
  619. MELVAL=IVAL(ICOMP)
  620. IF (MELVAL.NE.0) THEN
  621. IGMN=MIN(IGAU,VELCHE(/1))
  622. IBMN=MIN(IB ,VELCHE(/2))
  623. XDDL(IE)=VELCHE(IGMN,IBMN)
  624. ELSE
  625. XDDL(IE)=0.D0
  626. ENDIF
  627. 4027 CONTINUE
  628.  
  629. C
  630. CALL COQ3GF(XE,XDDL,GRADF,WORK)
  631. C
  632. C REMPLISAGE DU SEGMENT CONTENANT LES GRADIENT EN FLEXION
  633. C
  634. MPTVAL=IVAGRF
  635. DO 6027 IC=1,NGRAF
  636.  
  637. MELVAL=IVAL(IC)
  638. IBMN=MIN(IB ,VELCHE(/2))
  639. IF (IC.EQ.3.OR.IC.GE.6) THEN
  640. VELCHE(1,IBMN)=0.D0
  641. ELSE
  642. VELCHE(1,IBMN)=GRADF(IC)
  643. ENDIF
  644. 6027 CONTINUE
  645. C
  646. 3027 CONTINUE
  647. GOTO 510
  648. C ______________________
  649. C | ELEMENT DKT |
  650. C |_____________________|
  651. 28 CONTINUE
  652. NBNO=NBNN
  653. NBBB=NBNN
  654. SEGINI MWRK1,MWRK2,MWRK4
  655. DO 3028 IB=1,NBELEM
  656. C
  657. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  658. C
  659. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  660. C
  661. C ON CHERCHE LES DEPLACEMENTS
  662. C
  663. IE=0
  664. MPTVAL=IVADEP
  665. DO 4028 IGAU=1,NBNN
  666. DO 4028 ICOMP=1,NDEP
  667. IE=IE+1
  668. MELVAL=IVAL(ICOMP)
  669. IF (MELVAL.NE.0) THEN
  670. IGMN=MIN(IGAU,VELCHE(/1))
  671. IBMN=MIN(IB ,VELCHE(/2))
  672. XDDL(IE)=VELCHE(IGMN,IBMN)
  673. ELSE
  674. XDDL(IE)=0.D0
  675. ENDIF
  676. 4028 CONTINUE
  677.  
  678. CALL VPAST(XE,BPSS)
  679. C BPSS STOCKE LA MATRICE DE PASSAGE
  680. CALL VCORLC (XE,XEL,BPSS)
  681. CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  682. C
  683. C BOUCLE SUR LES POINTS DE GAUSS
  684. C
  685. DO 5028 IGAU=1,NBPGAU
  686. CALL BGFDKT(IGAU,MELE,LRE,IFOUR,XEL,BGF)
  687. CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
  688. C
  689. C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
  690. C
  691. MPTVAL=IVAGRF
  692. DO 9028 IC=1,NGRAF
  693. MELVAL=IVAL(IC)
  694. IGMN=MIN(IGAU,VELCHE(/1))
  695. IBMN=MIN(IB ,VELCHE(/2))
  696. IF (IC.EQ.3.OR.IC.GE.6) THEN
  697. VELCHE(IGMN,IBMN)=0.D0
  698. ELSE
  699. VELCHE(IGMN,IBMN)=GRADF(IC)
  700. ENDIF
  701. 9028 CONTINUE
  702. 5028 CONTINUE
  703. 3028 CONTINUE
  704. GOTO 510
  705. C ______________________
  706. C | ELEMENT DST |
  707. C |_____________________|
  708. 93 CONTINUE
  709. NBNO=NBNN
  710. NBBB=NBNN
  711. NV1=NMATT
  712. SEGINI MWRK1,MWRK2,MWRK3,MWRK4,MVELCH
  713. DO 3093 IB=1,NBELEM
  714. C
  715. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  716. C
  717. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  718. C
  719. C ON CHERCHE LES DEPLACEMENTS
  720. C
  721. IE=0
  722. MPTVAL=IVADEP
  723. DO 4093 IGAU=1,NBNN
  724. DO 4093 ICOMP=1,NDEP
  725. IE=IE+1
  726. MELVAL=IVAL(ICOMP)
  727. IF (MELVAL.NE.0) THEN
  728. IGMN=MIN(IGAU,VELCHE(/1))
  729. IBMN=MIN(IB ,VELCHE(/2))
  730. XDDL(IE)=VELCHE(IGMN,IBMN)
  731. ELSE
  732. XDDL(IE)=0.D0
  733. ENDIF
  734. 4093 CONTINUE
  735. C
  736. CALL VPAST(XE,BPSS)
  737. C BPSS STOCKE LA MATRICE DE PASSAGE
  738. CALL VCORLC (XE,XEL,BPSS)
  739. CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  740. C
  741. C ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
  742. C LES EXCENTREMENTS ET ON LES MOYENNE.
  743. C
  744. EPAIST=0.D0
  745. EXCEN=0.D0
  746. MPTVAL=IVACAR
  747. DO 8093 IGAU=1,NBPGAU
  748. MELVAL=IVAL(1)
  749. IF (MELVAL.NE.0) THEN
  750. IGMN=MIN(IGAU,VELCHE(/1))
  751. IBMN=MIN(IB,VELCHE(/2))
  752. EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  753. ELSE
  754. EPAIST=0.D0
  755. ENDIF
  756. *
  757. MELVAL=IVAL(2)
  758. IF (MELVAL.NE.0) THEN
  759. IGMN=MIN(IGAU,VELCHE(/1))
  760. IBMN=MIN(IB,VELCHE(/2))
  761. EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  762. ELSE
  763. EXCEN=0.D0
  764. ENDIF
  765. 8093 CONTINUE
  766. EPAIST=EPAIST/NBPGAU
  767. EXCEN=EXCEN/NBPGAU
  768. C
  769. C BOUCLE SUR LES POINTS DE GAUSS
  770. C
  771. DO 5093 IGAU=1,NBPGAU
  772. MPTVAL=IVAMAT
  773. DO 9193 IM=1,NMATT
  774. IF (IVAL(IM).NE.0) THEN
  775. MELVAL=IVAL(IM)
  776. IBMN=MIN(IB ,VELCHE(/2))
  777. IGMN=MIN(IGAU,VELCHE(/1))
  778. VALMAT(IM)=VELCHE(IGMN,IBMN)
  779. ELSE
  780. VALMAT(IM)=0.D0
  781. ENDIF
  782. 9193 CONTINUE
  783. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  784. 1 CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD1)
  785. CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  786. CALL ZERO(BGF,NGRAF,LRE)
  787. C
  788. C CALCUL DES FONCTIONS HS4,HS5 ET HS6
  789. C
  790. CALL HS456(XEL,NSTRS,DDHOMU,WORK(1),WORK(10),WORK(19))
  791. C
  792. C TERMES DE LA MATRICE DE BGF RELATIFS
  793. C AUX DEFORMATONS DE FLEXION
  794. C
  795. CALL BGFDST(IGAU,XEL,NGRAF,QSIGAU,ETAGAU,
  796. 1 WORK(1),WORK(10),WORK(19),BGF)
  797. CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
  798. C
  799. C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
  800. C
  801. MPTVAL=IVAGRF
  802. DO 9093 IC=1,NGRAF
  803. MELVAL=IVAL(IC)
  804. IGMN=MIN(IGAU,VELCHE(/1))
  805. IBMN=MIN(IB ,VELCHE(/2))
  806. IF (IC.EQ.3.OR.IC.GE.6) THEN
  807. VELCHE(IGMN,IBMN)=0.D0
  808. ELSE
  809. VELCHE(IGMN,IBMN)=GRADF(IC)
  810. ENDIF
  811. 9093 CONTINUE
  812. 5093 CONTINUE
  813. 3093 CONTINUE
  814. GOTO 510
  815. C _____________________________________
  816. C | COQUES A 4 NOEUDS COQ4 |
  817. C |___________________________________|
  818. 49 CONTINUE
  819. NBNO=NBNN
  820. NBBB=NBNN
  821. SEGINI MWRK1,MWRK2,MWRK4
  822. DO 3049 IB=1,NBELEM
  823. C
  824. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  825. C
  826. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  827. C
  828. CALL CQ4LOC(XE,XEL,BPSS,IERT,IUN)
  829. C IERT=1 NODI TROPPO VICINI
  830. C IERT=2 NODI ELEMENTO NON COMPLANARI
  831. IF(IERT.NE.0)THEN
  832. IF(IERT.EQ.1)IMESS=323
  833. IF(IERT.EQ.2)IMESS=322
  834. GO TO 9990
  835. ENDIF
  836. C
  837. C ON CHERCHE LES DEPLACEMENTS
  838. C
  839. IE=0
  840. MPTVAL=IVADEP
  841. DO 2049 IGAU=1,NBNN
  842. DO 2049 ICOMP=1,NDEP
  843. IE=IE+1
  844. MELVAL=IVAL(ICOMP)
  845. IF (MELVAL.NE.0) THEN
  846. IGMN=MIN(IGAU,VELCHE(/1))
  847. IBMN=MIN(IB ,VELCHE(/2))
  848. XDDL(IE)=VELCHE(IGMN,IBMN)
  849. ELSE
  850. XDDL(IE)=0.D0
  851. ENDIF
  852. 2049 CONTINUE
  853.  
  854. C
  855. CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  856. C
  857. C BOUCLE SUR LES POINTS DE GAUSS
  858. C
  859. DO 4049 IGAU=1,NBPGAU
  860. C
  861. C APPEL A BGFCQ4
  862. C
  863. CALL BGFCQ4(IGAU,XEL,SHPTOT,SHPWRK,BGF,DJAC,IERT)
  864. C IERT=1 JACOBIANO <= 0
  865. IF(IERT.EQ.1)THEN
  866. IMESS=321
  867. GO TO 9990
  868. ENDIF
  869. C
  870. CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
  871. C
  872. C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
  873. C
  874. MPTVAL=IVAGRF
  875. DO 9049 IC=1,NGRAF
  876. MELVAL=IVAL(IC)
  877. IGMN=MIN(IGAU,VELCHE(/1))
  878. IBMN=MIN(IB ,VELCHE(/2))
  879. IF (IC.EQ.3.OR.IC.GE.6) THEN
  880. VELCHE(IGMN,IBMN)=0.D0
  881. ELSE
  882. VELCHE(IGMN,IBMN)=GRADF(IC)
  883. ENDIF
  884. 9049 CONTINUE
  885. C
  886. 4049 CONTINUE
  887. 3049 CONTINUE
  888. GO TO 510
  889.  
  890. C __________
  891. C | |
  892. C | COQ2 |
  893. C |__________|
  894. C
  895. 44 CONTINUE
  896. NBNO=NBNN
  897. SEGINI MWRK1,MWRK2
  898. C
  899. C Valeur de l'excentrement ne sert pas (pour l'instant ?)
  900. EXCEN=0.D0
  901. C
  902. NDDD=NDEP
  903. IF (IFOUR.EQ.-3) NDDD=NDEP-3
  904. DO 3044 IB=1,NBELEM
  905. C
  906. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  907. C
  908. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  909. C
  910. C ON CHERCHE LES DEPLACEMENTS
  911. C
  912. MPTVAL=IVADEP
  913. IE=1
  914. DO 2044 IGAU=1,NBNN
  915. DO 2044 ICOMP=1,NDDD
  916. MELVAL=IVAL(ICOMP)
  917. IGMN=MIN(IGAU,VELCHE(/1))
  918. IBMN=MIN(IB ,VELCHE(/2))
  919. XDDL(IE)=VELCHE(IGMN,IBMN)
  920. IE=IE+1
  921. 2044 CONTINUE
  922. IF (IFOUR.EQ.-3) THEN
  923. XDDL(IE)=UZDPG
  924. XDDL(IE+1)=RYDPG
  925. XDDL(IE+2)=RXDPG
  926. ENDIF
  927. C
  928. C BOUCLE SUR LES POINTS DE GAUSS
  929. C
  930. DO 4044 IGAU=1,NBPGAU
  931. IF (IVACAR.NE.0) THEN
  932. MPTVAL=IVACAR
  933. IF (IVAL(/1).GT.1) THEN
  934. IF (IVAL(2).NE.0) THEN
  935. MELVAL=IVAL(2)
  936. IBMN=MIN(IB,VELCHE(/2))
  937. EXCEN=VELCHE(1,IBMN)
  938. ENDIF
  939. ENDIF
  940. ENDIF
  941. C
  942. C APPEL A BGFCQ2
  943. C
  944. CALL BGFCQ2(BGF,NGRAF,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  945. . EXCEN,1.D0,IRR,XDPGE,YDPGE)
  946. C
  947. C GESTION D'ERREUR
  948. C
  949. IF (IRR.EQ.1) THEN
  950. INTERR(1)=IB
  951. CALL ERREUR(255)
  952. GOTO 9990
  953. ELSE IF(IRR.EQ.2) THEN
  954. INTERR(1)=IB
  955. CALL ERREUR(256)
  956. GOTO 9990
  957. ENDIF
  958. C
  959. CALL BST(BGF,XDDL,LRE,NGRAF,GRADF)
  960. C
  961. C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS DE FLEXION
  962. C
  963. MPTVAL=IVAGRF
  964. DO 9044 ICOMP=1,NGRAF
  965. MELVAL=IVAL(ICOMP)
  966. IGMN=MIN(IGAU,VELCHE(/1))
  967. IBMN=MIN(IB ,VELCHE(/2))
  968. VELCHE(IGMN,IBMN)=GRADF(ICOMP)
  969. 9044 CONTINUE
  970. 4044 CONTINUE
  971. 3044 CONTINUE
  972. C
  973. GOTO 510
  974.  
  975.  
  976. C
  977. C POUTRE, TUYA, TIMO
  978. C
  979.  
  980. 29 CONTINUE
  981. NBNO=NBNN
  982. NBBB=NBNN
  983.  
  984. SEGINI MWRK1,MWRK3
  985. DO 3029 IB=1,NBELEM
  986. C
  987. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  988. C
  989. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  990. C
  991. C ON CHERCHE LES DEPLACEMENTS
  992. C
  993. IE=0
  994. MPTVAL=IVADEP
  995. DO 4029 IGAU=1,NBNN
  996. DO 4029 ICOMP=1,NDEP
  997. IE=IE+1
  998. MELVAL=IVAL(ICOMP)
  999. IF (MELVAL.NE.0) THEN
  1000. IGMN=MIN(IGAU,VELCHE(/1))
  1001. IBMN=MIN(IB ,VELCHE(/2))
  1002. XDDL(IE)=VELCHE(IGMN,IBMN)
  1003. ELSE
  1004. XDDL(IE)=0.D0
  1005. ENDIF
  1006. 4029 CONTINUE
  1007. C
  1008. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  1009. C
  1010. CALL ZERO(WORK,NCAR,1)
  1011. DO 5029 IGAU=1,NBNN
  1012. MPTVAL=IVACAR
  1013. DO 6029 IC=1,NCAR
  1014. IF(IVAL(IC).NE.0) THEN
  1015. MELVAL=IVAL(IC)
  1016. IBMN=MIN(IB,VELCHE(/2))
  1017. IGMN=MIN(IGAU,VELCHE(/1))
  1018. IF(IGMN.GT.0.AND.IBMN.GT.0) THEN
  1019. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  1020. ELSE
  1021. WORK(IC)=0.
  1022. ENDIF
  1023. ELSE
  1024. WORK(IC)=0.
  1025. ENDIF
  1026. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  1027. 6029 CONTINUE
  1028. 5029 CONTINUE
  1029. C
  1030. C CAS OU ON A LU LE MOT VECTEUR
  1031. C
  1032. IF (IFOUR.EQ.2) THEN
  1033. C
  1034. IF (IVECT.EQ.1) THEN
  1035. IF (IVAL(NCAR).NE.0) THEN
  1036. MELVAL=IVAL(NCAR)
  1037. IBMN=MIN(IB,IELCHE(/2))
  1038. IP=IELCHE(1,IBMN)
  1039. IREF=(IP-1)*(IDIM+1)
  1040. DO 6129 IC=1,IDIM
  1041. WORK(NCAR+IC-1)=XCOOR(IREF+IC)
  1042. 6129 CONTINUE
  1043. ELSE
  1044. DO 6229 IC=1,IDIM
  1045. WORK(NCAR+IC-1)=0.D0
  1046. 6229 CONTINUE
  1047. ENDIF
  1048. ENDIF
  1049. C
  1050. ENDIF
  1051. C
  1052. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  1053. C EQUIVALENTE
  1054. IF(MELE.EQ.42) THEN
  1055. CISA=WORK(4)
  1056. VX=WORK(5)
  1057. VY=WORK(6)
  1058. VZ=WORK(7)
  1059. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  1060. ENDIF
  1061. C
  1062. C ON CALCULE LES GRADIENTS
  1063. C
  1064. IF(MELE.EQ.84) THEN
  1065. C
  1066. IF(CMATE.EQ.'SECTION') THEN
  1067. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1068. CALL TIMGF2(XE,XDDL,WORK(12),WORK(25))
  1069. ELSE
  1070. CALL TIMGF1(XE,XDDL,WORK(1),WORK(12),WORK(25))
  1071. ENDIF
  1072. ELSE
  1073. C
  1074. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1075. CALL TIMGF2(XE,XDDL,WORK(12),WORK(25))
  1076. C
  1077. ELSE
  1078. CALL TIMGF1(XE,XDDL,WORK(7),WORK(12),WORK(25))
  1079. ENDIF
  1080. ENDIF
  1081. ELSE
  1082. C
  1083. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1084. CALL POUGF2(XE,XDDL,WORK,WORK(12),WORK(25))
  1085. ELSE
  1086. C
  1087. CALL POUGF1(XE,XDDL,WORK,WORK(12),WORK(25))
  1088. ENDIF
  1089. ENDIF
  1090.  
  1091. * REMPLISSAGE
  1092.  
  1093. DO iGau=1,NBPGAU
  1094. MPTVAL=IVAGRF
  1095. DO i=1,NGRAF
  1096. MELVAL=IVAL(i)
  1097. IGMN=MIN(iGau,VELCHE(/1))
  1098. IBMN=MIN(IB,VELCHE(/2))
  1099. * IDECA=11+I+(IGAU-1)*NGRAF
  1100. VELCHE(IGMN,IBMN)=WORK(I)
  1101. ENDDO
  1102. ENDDO
  1103. 3029 CONTINUE
  1104. GOTO 510
  1105. C
  1106. C JOINT UNIDIMENSIONNELS JOI1
  1107. C
  1108. 265 CONTINUE
  1109. NBNO=NBNN
  1110. NBBB=NBNN
  1111. SEGINI MWRK1,MWRK3,MWRK4
  1112. DO 3265 IB=1,NBELEM
  1113. C
  1114. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  1115. C
  1116. MPTVAL=IVAMAT
  1117. DO IC=1,NMATT
  1118. IF(IVAL(IC).NE.0) THEN
  1119. MELVAL=IVAL(IC)
  1120. IBMN=MIN(IB,VELCHE(/2))
  1121. WORK(IC)=VELCHE(1,IBMN)
  1122. ELSE
  1123. WORK(IC)=0.D0
  1124. ENDIF
  1125. END DO
  1126. C
  1127. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1128. C
  1129. C ON CHERCHE LES DEPLACEMENTS
  1130. C
  1131. IE=0
  1132. MPTVAL=IVADEP
  1133. DO 4265 IGAU=1,NBNN
  1134. DO 4265 ICOMP=1,NDEP
  1135. IE=IE+1
  1136. MELVAL=IVAL(ICOMP)
  1137. IF (MELVAL.NE.0) THEN
  1138. IGMN=MIN(IGAU,VELCHE(/1))
  1139. IBMN=MIN(IB ,VELCHE(/2))
  1140. XDDL(IE)=VELCHE(IGMN,IBMN)
  1141. ELSE
  1142. XDDL(IE)=0.D0
  1143. ENDIF
  1144. 4265 CONTINUE
  1145. C
  1146. C CALCUL DES DEPLACEMENTS LOCAUX
  1147. C
  1148. IAW1 = 101
  1149. IAW2 = IAW1 + LRE
  1150. CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1151. C
  1152. C ON CALCULE LES GRADIENTS
  1153. C
  1154. CALL JOIGF1(XDDL,WORK,LRE,NGRAF,IDIM)
  1155. * REMPLISSAGE
  1156. DO iGau=1,NBPGAU
  1157. MPTVAL=IVAGRF
  1158. DO i=1,NGRAF
  1159. MELVAL=IVAL(i)
  1160. IGMN=MIN(iGau,VELCHE(/1))
  1161. IBMN=MIN(IB,VELCHE(/2))
  1162. IDECA=11+I+(IGAU-1)*NGRAF
  1163. VELCHE(IGMN,IBMN)=WORK(IDECA)
  1164. ENDDO
  1165. ENDDO
  1166. 3265 CONTINUE
  1167. GOTO 510
  1168.  
  1169. C
  1170. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  1171. C
  1172. 510 CONTINUE
  1173. * Desactivation des segments
  1174. *
  1175. IF (MWRK1.NE.0) SEGSUP,MWRK1
  1176. IF (MWRK2.NE.0) SEGSUP,MWRK2
  1177. IF (MWRK3.NE.0) SEGSUP,MWRK3
  1178. IF (MWRK4.NE.0) SEGSUP,MWRK4
  1179. IF (MVELCH.NE.0) SEGSUP,MVELCH
  1180. *
  1181. CALL DTMVAL(IVADEP,1)
  1182. *
  1183. CALL DTMVAL(IVAMAT,1)
  1184. *
  1185. CALL DTMVAL(IVACAR,1)
  1186. *
  1187. CALL DTMVAL(IVAGRF,1)
  1188. *
  1189. NOMID=MODEPL
  1190. if(lsupdp)SEGSUP NOMID
  1191. NOMID=MOGRAF
  1192. if(lsupgf)SEGSUP NOMID
  1193. IF (MOMATR.NE.0) THEN
  1194. NOMID=MOMATR
  1195. SEGSUP NOMID
  1196. ENDIF
  1197. IF (MOCARA.NE.0) THEN
  1198. NOMID=MOCARA
  1199. SEGSUP NOMID
  1200. ENDIF
  1201. *
  1202. * SEGSUP INFO
  1203. SEGDES,IMODEL,MELEME
  1204. SEGDES,MCHAML,MINTE
  1205. *
  1206. 500 CONTINUE
  1207. SEGDES,MMODEL,MCHELM
  1208. * CALL DTCHAM(IPCHE2)
  1209. *
  1210. RETURN
  1211. *
  1212. 9990 CONTINUE
  1213. *
  1214. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1215. *
  1216. IRET=0
  1217. *
  1218. * Gestion des messages d'erreur
  1219. *
  1220. IF (IMESS.NE.0) THEN
  1221. INTERR(1) = IB
  1222. CALL ERREUR(IMESS)
  1223. ENDIF
  1224. *
  1225. IF (MWRK1.NE.0) SEGSUP,MWRK1
  1226. IF (MWRK2.NE.0) SEGSUP,MWRK2
  1227. IF (MWRK3.NE.0) SEGSUP,MWRK3
  1228. IF (MWRK4.NE.0) SEGSUP,MWRK4
  1229. IF (MVELCH.NE.0) SEGSUP,MVELCH
  1230. *
  1231. CALL DTMVAL(IVADEP,1)
  1232. *
  1233. CALL DTMVAL(IVAMAT,1)
  1234. *
  1235. CALL DTMVAL(IVACAR,1)
  1236. *
  1237. CALL DTMVAL(IVAGRF,3)
  1238. *
  1239. IF(MODEPL.NE.0.and.lsupdp) THEN
  1240. NOMID=MODEPL
  1241. SEGSUP NOMID
  1242. ENDIF
  1243. *
  1244. IF(MOGRAF.NE.0)THEN
  1245. NOMID=MOGRAF
  1246. if(lsupgf)SEGSUP NOMID
  1247. ENDIF
  1248. *
  1249. IF (MOCARA.NE.0) THEN
  1250. NOMID=MOCARA
  1251. SEGSUP NOMID
  1252. ENDIF
  1253. *
  1254. IF (MOMATR.NE.0) THEN
  1255. NOMID=MOMATR
  1256. SEGSUP NOMID
  1257. ENDIF
  1258. *
  1259. SEGDES MELEME
  1260. SEGDES IMODEL
  1261. *
  1262. SEGDES MMODEL
  1263. IF (IPCHE1.NE.0) THEN
  1264. MCHELM=IPCHE1
  1265. SEGDES MCHELM
  1266. ENDIF
  1267. *
  1268. * IF (IPCHE2.NE.0) CALL DTCHAM(IPCHE2)
  1269. SEGDES MINTE
  1270. * SEGSUP INFO
  1271.  
  1272. RETURN
  1273. END
  1274.  
  1275.  
  1276.  
  1277.  
  1278.  
  1279.  
  1280.  
  1281.  
  1282.  
  1283.  
  1284.  
  1285.  
  1286.  
  1287.  
  1288.  
  1289.  
  1290.  
  1291.  
  1292.  
  1293.  
  1294.  
  1295.  
  1296.  
  1297.  

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