Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTRAI SOURCE BP208322 16/11/18 21:16:55 9177
  2. SUBROUTINE EXTRAI
  3. ************************************************************************
  4. * NOM : EXTRAI
  5. * DESCRIPTION : OPERATION D'EXTRACTION POUR DIFFERENTS TYPES D'OBJETS
  6. ************************************************************************
  7. * HISTORIQUE : 5/12/1985 : PASCAL MANIGOT : creation de la subroutine
  8. * HISTORIQUE : MODIFIE EN SEPTEMBRE 1994
  9. * HISTORIQUE : MODIFIE EN AVRIL 2015 PAR CB215821
  10. * ==> Extraire le MAILLAGE d'un MMODEL vide renvoie
  11. * un MAILLAGE vide au lieu d'une GEMAT ERROR
  12. * ==> Extraire un constituant d'un MMODEL vide
  13. * renvoie une erreur au lieu d'une GEMAT ERROR
  14. * HISTORIQUE : MODIFIE EN JANVIER 2016 PAR JCARDO
  15. * ==> ajout de la syntaxe EXTR LCHPO1 "VALE" ...
  16. * ==> extention du IF/ELSEIF/ENDIF principal a
  17. * tous les objets
  18. * ==> amelioration de la lisibilite de la subroutine
  19. ************************************************************************
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8(A-H,O-Z)
  22.  
  23. -INC CCOPTIO
  24. -INC CCGEOME
  25. -INC CCHAMP
  26.  
  27. -INC SMSUPER
  28. -INC SMRIGID
  29. -INC SMELEME
  30. -INC SMCHPOI
  31. -INC SMBASEM
  32. -INC SMTABLE
  33. -INC SMDEFOR
  34. -INC SMMODEL
  35. -INC SMEVOLL
  36. -INC SMLREEL
  37. -INC SMLENTI
  38. -INC SMLMOTS
  39. -INC SMLCHPO
  40. -INC SMNUAGE
  41.  
  42. SEGMENT LIMODE(0)
  43.  
  44. PARAMETER (NBFORM=100 , NBCHGT=8)
  45. CHARACTER*4 CAMPL(1), MOOPT(7), NOMU(3), LMOSU(5), MOTBAS(5),
  46. & NUMO(5), MCHGT(NBCHGT), CMOC(20)
  47. CHARACTER*16 MOFORM(NBFORM)
  48. CHARACTER*4 MOT_4,CMOT,MOT1,MOT2
  49. CHARACTER*8 MOT_8,CTYP,CTYP1
  50. CHARACTER*512 CTEXTL
  51. CHARACTER*72 CTEXT
  52. LOGICAL LTELQ, LAG,BORINF,MINI
  53. C
  54. DATA LMOSU /'RIGI','ELEM','RIGT','MASS','BLOQ'/
  55. DATA NOMU /'NOMU','MULT','UNIL'/
  56. DATA MOOPT /'MAIL','RIGI','SYME','ANTI','CONT','COMP','DIAG'/
  57. DATA MOTBAS/'RIGI','MASS','MODE','STAT','PSMO'/
  58. DATA CAMPL /'AMPL'/
  59. DATA NUMO /'INFE','SUPE','MINI','MAXI','ENTR'/
  60. DATA CMOC /'MAIL','ZONE','FORM','CONS','ELEM','GEOM','CONT',
  61. $ 'DEFO','DEPL','FORC','GRAD','GRAF','MATE','CONP',
  62. $ 'TEMP','VARI','PARA','DEIN','COMP','OBJE'/
  63. DATA MCHGT /'CHAR','CHAM','TRAJ','EVOL','VITE','COMP',
  64. & 'LIE ','LIBR' /
  65.  
  66. XVAL1=0.D0
  67. MOT_4=' '
  68. MINI =.FALSE.
  69. ILO =0
  70. IOBIN=0
  71. IVALRE=0
  72. C
  73. CALL QUETYP(CTYP,0,IRETOU)
  74. IF (IRETOU.EQ.0) THEN
  75. CALL ERREUR(533)
  76. RETURN
  77. ENDIF
  78.  
  79.  
  80.  
  81. * +-------------------------------------------------------------------+
  82. * | |
  83. * | M O T |
  84. * | |
  85. * +-------------------------------------------------------------------+
  86. IF (CTYP.EQ.'MOT ') THEN
  87. CALL LIRCHA(CTEXTL,1,LONMOT)
  88. IF (IERR.NE.0) RETURN
  89.  
  90. * ============================
  91. * EXTRACTION D'UNE SOUS-CHAINE
  92. * ============================
  93. CALL QUETYP(CTYP1,0,IRETOU)
  94. IF (IRETOU.NE.0) THEN
  95. IF (CTYP1.EQ.'ENTIER'.OR.CTYP1.EQ.'LISTENTI') THEN
  96. CALL SOUCHA(CTEXTL,LONMOT,CTYP1)
  97. RETURN
  98. ENDIF
  99. ENDIF
  100.  
  101. * ========================================================
  102. * CREATION D'UNE TABLE CONTENANT LES OBJETS DE TYPE CTEXTL
  103. * ========================================================
  104. MOT_8=CTEXTL(1:8)
  105. CALL REPERT(MOT_8,IA)
  106. M=IA
  107. SEGINI MTABLE
  108. MLOTAB=0
  109. DO 7765 I=1,IA
  110. IF(MOT_8.EQ.'FLOTTANT' ) THEN
  111. CALL LIRREE(XVAL,1,IRETOU)
  112. ELSEIF(MOT_8.EQ.'LOGIQUE ') THEN
  113. CALL LIRLOG(LAG,1,IRETOU)
  114. ELSEIF (MOT_8.EQ.'ENTIER ') THEN
  115. CALL LIRENT(IVAL,1,IRETOU)
  116. ELSEIF(MOT_8.EQ.'MOT ') THEN
  117. CALL LIRCHA(CTEXT,1,IRETOU)
  118. ELSE
  119. CALL LIROBJ(MOT_8,IVAL,1,IRETOU)
  120. ENDIF
  121. CALL ECCTAB(MTABLE,'ENTIER ',I,XVAL1,MOT_4,MINI,ILO,
  122. $ MOT_8,IVAL,XVAL,CTEXT(1:IRETOU),LAG,IVAL)
  123. 7765 CONTINUE
  124. SEGDES MTABLE
  125. CALL ECROBJ('TABLE ',MTABLE)
  126. RETURN
  127.  
  128.  
  129. * +-------------------------------------------------------------------+
  130. * | |
  131. * | D E F O R M E E |
  132. * | |
  133. * +-------------------------------------------------------------------+
  134. ELSE IF (CTYP.EQ.'DEFORME ') THEN
  135. CALL LIROBJ('DEFORME ',MDEFOR,1,IRETOU)
  136. IF(IERR.NE.0) RETURN
  137. CALL LIRMOT(CAMPL,1,IRET,1)
  138. IF(IERR.NE.0) RETURN
  139. SEGACT MDEFOR
  140. IF (AMPL(/1).NE.1) THEN
  141. CALL ERREUR(475)
  142. ELSE
  143. AMP=AMPL(1)
  144. CALL ECRREE(AMP)
  145. ENDIF
  146. SEGDES MDEFOR
  147. RETURN
  148.  
  149.  
  150. * +-------------------------------------------------------------------+
  151. * | |
  152. * | B A S E M O D A |
  153. * | |
  154. * +-------------------------------------------------------------------+
  155. ELSE IF (CTYP.EQ.'BASEMODA') THEN
  156. CALL LIROBJ('BASEMODA',IPBASE,1,IRETOU)
  157. IF(IERR.NE.0) RETURN
  158. CALL LIRMOT(MOTBAS,5,IRET,1)
  159. IF(IERR.NE.0) RETURN
  160. MOT_4=MOTBAS(IRET)
  161. CALL EXTRA7(IPBASE,MOT_4,IPTR)
  162. IF(IERR.NE.0) RETURN
  163. IF (IRET.LE.2) THEN
  164. CALL ECROBJ('RIGIDITE',IPTR)
  165. ELSE
  166. CALL ECROBJ('SOLUTION',IPTR)
  167. ENDIF
  168. RETURN
  169.  
  170.  
  171. * +-------------------------------------------------------------------+
  172. * | |
  173. * | E V O L U T I O N |
  174. * | |
  175. * +-------------------------------------------------------------------+
  176. ELSE IF (CTYP.EQ.'EVOLUTIO') THEN
  177. CALL LIROBJ('EVOLUTIO',IBOLL,1,IRETOU)
  178. IF(IERR.NE.0) RETURN
  179. CALL EXTRA6 (IBOLL)
  180. RETURN
  181.  
  182.  
  183. * +-------------------------------------------------------------------+
  184. * | |
  185. * | S U P E R E L E |
  186. * | |
  187. * +-------------------------------------------------------------------+
  188. ELSE IF (CTYP.EQ.'SUPERELE') THEN
  189. CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU)
  190. IF (IERR.NE.0) RETURN
  191. CALL LIRMOT(LMOSU,5,IRET,1)
  192. IF (IERR.NE.0) RETURN
  193. SEGACT MSUPER
  194.  
  195. * ==============
  196. * MOT-CLE "RIGI"
  197. * ==============
  198. IF (IRET.EQ.1) THEN
  199. IPTR=MSURAI
  200. CALL ECROBJ('RIGIDITE',IPTR)
  201.  
  202. * ==============
  203. * MOT-CLE "ELEM"
  204. * ==============
  205. ELSEIF (IRET.EQ.2) THEN
  206. IPTR=MSUPEL
  207. CALL ECROBJ('MAILLAGE',IPTR)
  208.  
  209. * ==============
  210. * MOT-CLE "RIGT"
  211. * ==============
  212. ELSEIF (IRET.EQ.3) THEN
  213. IPTR=MRIGTO
  214. CALL ECROBJ('RIGIDITE',IPTR)
  215.  
  216. * ==============
  217. * MOT-CLE "MASS"
  218. * ==============
  219. ELSEIF (IRET.EQ.4) THEN
  220. IPTR=MSUMAS
  221. CALL ECROBJ('RIGIDITE',IPTR)
  222.  
  223. * ==============
  224. * MOT-CLE "BLOQ"
  225. * ==============
  226. ELSEIF (IRET.EQ.5) THEN
  227. NRIGEL=MBLOQU
  228. RI1=MRIGTO
  229. SEGACT,RI1
  230. SEGINI,MRIGID
  231. MTYMAT=RI1.MTYMAT
  232. DO 1 IE1=1,NRIGEL
  233. COERIG(IE1)=RI1.COERIG(IE1)
  234. DO 11 IE2=1,8
  235. IRIGEL(IE2,IE1)=RI1.IRIGEL(IE2,IE1)
  236. 11 CONTINUE
  237. 1 CONTINUE
  238. SEGDES,RI1,MRIGID
  239. CALL ECROBJ('RIGIDITE',MRIGID)
  240. ENDIF
  241.  
  242. SEGDES MSUPER
  243. RETURN
  244.  
  245.  
  246. * +-------------------------------------------------------------------+
  247. * | |
  248. * | M A T R I K |
  249. * | |
  250. * +-------------------------------------------------------------------+
  251. ELSE IF (CTYP.EQ.'MATRIK') THEN
  252. CALL LIROBJ ('MATRIK',IBOGID,1,IRETOU)
  253. IF (IERR.NE.0) RETURN
  254. CALL LIRMOT(MOOPT,7,IRET,0)
  255.  
  256. * ====================================================
  257. * EXTRACTION D'UNE SOUS-MATRICE DE COMPOSANTES DONNEES
  258. * ====================================================
  259. IF (IRET.EQ.0) THEN
  260. CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM)
  261. IF (IRETLM.EQ.1) THEN
  262. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
  263. IF (IERR.NE.0) RETURN
  264. ELSE
  265. CALL LIRCHA(MOT1,1,IRET)
  266. IF (IERR.NE.0) RETURN
  267. CALL LIRCHA(MOT2,1,IRET)
  268. IF (IERR.NE.0) RETURN
  269. JGN=4
  270. JGM=1
  271. SEGINI MLMOT1,MLMOT2
  272. MLMOT1.MOTS(1)=MOT1
  273. MLMOT2.MOTS(1)=MOT2
  274. ENDIF
  275. CALL EXINCK(IBOGID,MLMOT1,MLMOT2,IOUT,IMPR,IRET)
  276. IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2
  277. IF (IERR.NE.0) RETURN
  278. CALL ECROBJ('MATRIK',IOUT)
  279. RETURN
  280.  
  281. * ============================================
  282. * MOT-CLE "DIAG" => EXTRACTION DE LA DIAGONALE
  283. * ============================================
  284. ELSEIF (IRET.EQ.7) THEN
  285. CALL ECROBJ('MATRIK',IBOGID)
  286. CALL EXDIAG(1)
  287. RETURN
  288.  
  289. * =======================================================
  290. * MOT-CLE "COMP => EXTRACTION DE LA LISTE DES COMPOSANTES
  291. * =======================================================
  292. ELSEIF(IRET.EQ.6) THEN
  293. CALL LIRCHA(CMOT,0,ICDUAL)
  294. IF (ICDUAL.NE.0) THEN
  295. IF (CMOT.NE.'DUAL') THEN
  296. MOTERR(1:4)=CMOT
  297. CALL ERREUR(7)
  298. RETURN
  299. ENDIF
  300. ENDIF
  301. CALL EXTR26(IBOGID,ICDUAL,IPLSTM)
  302. CALL ECROBJ('LISTMOTS',IPLSTM)
  303. RETURN
  304. ELSE
  305. MOTERR(1:4)=MOOPT(IRET)
  306. CALL ERREUR(7)
  307. RETURN
  308. ENDIF
  309.  
  310.  
  311. * +-------------------------------------------------------------------+
  312. * | |
  313. * | R I G I D I T E |
  314. * | |
  315. * +-------------------------------------------------------------------+
  316. ELSE IF (CTYP.EQ.'RIGIDITE') THEN
  317. CALL LIROBJ ('RIGIDITE',IBOGID,1,IRETOU)
  318. IF (IERR.NE.0) RETURN
  319. CALL LIRMOT(MOOPT,7,IRET,0)
  320.  
  321. * ====================================================
  322. * EXTRACTION D'UNE SOUS-MATRICE DE COMPOSANTES DONNEES
  323. * ====================================================
  324. IF (IRET.EQ.0) THEN
  325. CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM)
  326. IF (IRETLM.EQ.1) THEN
  327. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
  328. IF (IERR.NE.0) RETURN
  329. ELSE
  330. CALL LIRCHA(MOT1,1,IRET)
  331. IF (IERR.NE.0) RETURN
  332. CALL LIRCHA(MOT2,1,IRET)
  333. IF (IERR.NE.0) RETURN
  334. JGN=4
  335. JGM=1
  336. SEGINI MLMOT1,MLMOT2
  337. MLMOT1.MOTS(1)=MOT1
  338. MLMOT2.MOTS(1)=MOT2
  339. ENDIF
  340. CALL EXINCR(IBOGID,MLMOT1,MLMOT2,IOUT)
  341. IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2
  342. IF (IERR.NE.0) RETURN
  343. CALL ECROBJ('RIGIDITE',IOUT)
  344. RETURN
  345.  
  346. * ============================================
  347. * MOT-CLE "DIAG" => EXTRACTION DE LA DIAGONALE
  348. * ============================================
  349. ELSEIF (IRET.EQ.7) THEN
  350. CALL EXDIAR(IBOGID,ICHP)
  351. IF (IERR.NE.0) RETURN
  352. CALL ECROBJ('CHPOINT ',ICHP)
  353. RETURN
  354.  
  355. * ========================================================
  356. * MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  357. * ========================================================
  358. ELSEIF(IRET.EQ.6) THEN
  359. CALL LIRCHA(CMOT,0,ICDUAL)
  360. IF (ICDUAL.NE.0) THEN
  361. IF (CMOT.NE.'DUAL') THEN
  362. MOTERR(1:4)=CMOT
  363. CALL ERREUR(7)
  364. RETURN
  365. ENDIF
  366. ENDIF
  367. CALL EXTR16(IBOGID,ICDUAL,IPLSTM)
  368. CALL ECROBJ('LISTMOTS',IPLSTM)
  369. RETURN
  370.  
  371. * ====================================
  372. * MOT-CLE "CONT" => APPUIS UNILATERAUX
  373. * ====================================
  374. ELSEIF(IRET.EQ.5) THEN
  375. MRIGID=IBOGID
  376. SEGACT MRIGID
  377. ISOPE= ISUPEQ
  378. IF(ISUPEQ.EQ.0) CALL CRTABL(ISOPE)
  379. MTABLE=ISOPE
  380. SEGDES MTABLE
  381. CALL ECROBJ('TABLE ',ISOPE)
  382. RETURN
  383.  
  384. * ==============================================================
  385. * MOTS-CLES "SYME" OU "ANTI" => SOUS-MATRICES (ANTI-)SYMETRIQUES
  386. * ==============================================================
  387. ELSEIF (IRET.EQ.3 .OR. IRET.EQ.4) THEN
  388. CALL EXTR13(IBOGID,IRET)
  389. RETURN
  390. ENDIF
  391.  
  392.  
  393. * =============================================================
  394. * MOTS-CLES "MAIL" OU "RIGI" => SOUS-MAILLAGES OU SOUS-MATRICES
  395. * =============================================================
  396. ICO=0
  397. IMO=3
  398. IF(IRET.EQ.2) THEN
  399. ICO=1
  400. IMO=2
  401. ENDIF
  402. CALL LIRMOT(NOMU,IMO,IMUL,ICO)
  403. IF(IERR.NE.0) RETURN
  404.  
  405. * ************************************************
  406. * MATRICE AVEC SEULEMENT LES MULT. DE LAGRANGE OU
  407. * AVEC TOUT SAUF LES MULT. DE LAGRANGE
  408. * ************************************************
  409. IF (IRET.EQ.2) THEN
  410. CALL SEPA(IBOGID,IMUL)
  411. CALL ECROBJ('RIGIDITE',IBOGID)
  412. RETURN
  413. ENDIF
  414.  
  415. * ********************************************************
  416. * MAILLAGE PARTIEL
  417. * "NOMU" => TOUT SAUF LES MULT. DE LAGRANGE
  418. * "MULT" => TOUS LES MULT. DE LAGRANGE
  419. * "UNIL" => SEULEMENT LES MULT. ASSOCIES AUX COND. UNIL.
  420. * ********************************************************
  421. IF (IMUL.NE.0) THEN
  422. CALL POIRIG(IBOGID,IMUL)
  423. RETURN
  424. ENDIF
  425.  
  426. * ****************
  427. * MAILLAGE COMPLET
  428. * ****************
  429. IF (IERR.NE.0) RETURN
  430. MRIGID=IBOGID
  431. SEGACT MRIGID
  432. NBSOUS=IRIGEL(/2)
  433. IF (NBSOUS.EQ.0) THEN
  434. NBNN=0
  435. NBELEM=0
  436. NBREF=0
  437. SEGINI MELEME
  438. SEGDES MELEME,MRIGID
  439. CALL ECROBJ ('MAILLAGE',MELEME)
  440. RETURN
  441. ENDIF
  442. IPP1 = IRIGEL(1,1)
  443. IF(NBSOUS.GT.1) THEN
  444. NBREF=0
  445. NBNN=0
  446. NBELEM=0
  447. SEGINI IPT4
  448. KT4 = 1
  449. IPT4.LISOUS(KT4) = IPP1
  450. DO 1130 I=1,NBSOUS
  451. DO 1129 JJ = 1,KT4
  452. IF (IRIGEL(1,I).EQ.IPT4.LISOUS(JJ)) GOTO 1130
  453. 1129 CONTINUE
  454. KT4 = KT4 + 1
  455. IPT4.LISOUS(KT4)=IRIGEL(1,I)
  456. 1130 CONTINUE
  457. NBSOUS = KT4
  458. SEGADJ IPT4
  459. CALL FUSEBO (IPT4,IPP1)
  460. ENDIF
  461. SEGDES MRIGID
  462. CALL ECROBJ('MAILLAGE',IPP1)
  463. RETURN
  464.  
  465.  
  466. * +-------------------------------------------------------------------+
  467. * | |
  468. * | C H P O I N T |
  469. * | |
  470. * +-------------------------------------------------------------------+
  471. ELSE IF (CTYP.EQ.'CHPOINT') THEN
  472. CALL LIROBJ('CHPOINT ',IBOPOI,1,IRETOU)
  473. IF (IERR.NE.0) RETURN
  474. CALL LIRCHA(CMOT,1,IRETOU)
  475. IF (IERR.NE.0) RETURN
  476.  
  477. * =====================================
  478. * MOT-CLE "TITR" => EXTRACTION DU TITRE
  479. * =====================================
  480. IF (CMOT.EQ.'TITR') THEN
  481. MCHPOI = IBOPOI
  482. SEGACT MCHPOI
  483. CTEXT = MOCHDE
  484. SEGDES MCHPOI
  485. ILON = LEN(CTEXT)
  486. DO 100 I = ILON,1,-1
  487. IF (CTEXT(I:I).NE.' ') THEN
  488. NLON = I
  489. GOTO 102
  490. ENDIF
  491. 100 CONTINUE
  492. NLON = 1
  493. 102 CONTINUE
  494. CALL ECRCHA(CTEXT(1:NLON))
  495. RETURN
  496.  
  497. * =========================================
  498. * MOT-CLE "NATU" => EXTRACTION DE LA NATURE
  499. * =========================================
  500. ELSE IF (CMOT.EQ.'NATU') THEN
  501. MCHPOI = IBOPOI
  502. SEGACT MCHPOI
  503. INAT = JATTRI(1)
  504. IF (INAT.EQ.0) CTEXT(1:11) = 'INDETERMINE'
  505. IF (INAT.EQ.1) CTEXT(1:11) = 'DIFFUS '
  506. IF (INAT.EQ.2) CTEXT(1:11) = 'DISCRET '
  507. SEGDES MCHPOI
  508. CALL ECRCHA(CTEXT(1:11))
  509. RETURN
  510.  
  511. * ===================================================
  512. * MOT-CLE "MAIL" => EXTRACTION DU SUPPORT GEOMETRIQUE
  513. * ===================================================
  514. ELSE IF (CMOT .EQ.'MAIL') THEN
  515. IMUL=0
  516. CALL LIRMOT(NOMU,1,IMUL,0)
  517. MCHPOI=IBOPOI
  518. SEGACT MCHPOI
  519. NBSOUS=IPCHP(/1)
  520. IPP1=0
  521. DO 1140 I=1,NBSOUS
  522. MSOUPO=IPCHP(I)
  523. SEGACT MSOUPO
  524. IF(NOCOMP(1).EQ.'LX '.AND.IMUL.EQ.1) GO TO 1140
  525. IF (IPP1.EQ.0) THEN
  526. IPP1= IGEOC
  527. ELSE
  528. IPP2=IGEOC
  529. ltelq=.false.
  530. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  531. IPP1=IRET
  532. ENDIF
  533. SEGDES MSOUPO
  534. 1140 CONTINUE
  535. SEGDES MCHPOI
  536. IF(IPP1.EQ.0) THEN
  537. C Creation Maillage vide
  538. NBELEM=0
  539. NBNN=0
  540. NBREF=0
  541. NBSOUS=0
  542. SEGINI MELEME
  543. ITYPEL = 1
  544. IPP1 = MELEME
  545. C CALL ECRENT( 0)
  546. C ELSE
  547. ENDIF
  548. CALL ECROBJ('MAILLAGE',IPP1)
  549. RETURN
  550.  
  551. * ========================================================
  552. * MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  553. * ========================================================
  554. ELSE IF (CMOT .EQ.'COMP') THEN
  555. CALL EXTR11(IBOPOI,KLISTM)
  556. CALL ECROBJ('LISTMOTS',KLISTM)
  557. RETURN
  558.  
  559. * ====================================
  560. * MOT-CLE "TYPE" => EXTRACTION DU TYPE
  561. * ====================================
  562. ELSE IF (CMOT.EQ.'TYPE') THEN
  563. MCHPOI = IBOPOI
  564. SEGACT MCHPOI
  565. MOT_8 = MTYPOI
  566. SEGDES MCHPOI
  567. CALL ECRCHA(MOT_8(1:8))
  568. RETURN
  569.  
  570. * ============================================================
  571. * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN PLUSIEURS POINTS
  572. * ET POUR PLUSIEURS COMPOSANTES
  573. * ============================================================
  574. ELSE IF (CMOT.EQ.'VALE') THEN
  575. *
  576. * LISTE DES COMPOSANTES (OBJET MOT OU LISTMOTS)
  577. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  578. IF (IRETOU.EQ.0) THEN
  579. CALL LIRCHA(MOT_4,0,IRETOU)
  580. IF (IRETOU.GT.0) THEN
  581. JGN=4
  582. JGM=1
  583. SEGINI,MLMOTS
  584. MOTS(1)=MOT_4
  585. SEGDES,MLMOTS
  586. ENDIF
  587. ENDIF
  588. *
  589. * LISTE DES NOEUDS (OBJET POINT OU MAILLAGE DE POI1)
  590. CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  591. IF (IRETOU.EQ.0) THEN
  592. CALL LIROBJ('POINT',IPOINT,0,IRETOU)
  593. IF (IRETOU.NE.0) THEN
  594. CALL CRELEM(IPOINT)
  595. MELEME=IPOINT
  596. ENDIF
  597. ENDIF
  598. *
  599. * MOT-CLE 'NOID'
  600. IVID=0
  601. CALL LIRCHA(MOT_4,0,IRETOU)
  602. IF (IRETOU.NE.0) THEN
  603. IF (MOT_4.EQ.'NOID') THEN
  604. IVID=1
  605. ELSE
  606. MOTERR(1:4)=MOT_4
  607. MOTERR(5:40)='NOID'
  608. CALL ERREUR(1052)
  609. RETURN
  610. ENDIF
  611. ENDIF
  612. *
  613. * APPEL A EXTR23
  614. CALL EXTR23(IBOPOI,MLMOTS,MELEME,MLREEL,IVID)
  615. IF (IERR.NE.0) RETURN
  616. CALL ECROBJ('LISTREEL',MLREEL)
  617. RETURN
  618.  
  619. * ===========================================================
  620. * EXTRACTION DE LA VALEUR EN UN POINT D'UNE COMPOSANTE DONNEE
  621. * ===========================================================
  622. ELSE
  623. CALL LIROBJ('POINT ',MPOINT,1,IRETOU)
  624. IF (IRETOU.EQ.0) THEN
  625. MOTERR(1:8)='POINT'
  626. CALL ERREUR(37)
  627. RETURN
  628. ENDIF
  629. CALL EXTRA9(IBOPOI,MPOINT,CMOT,KERRE,XFLOT)
  630. IF (KERRE.EQ.0) THEN
  631. CALL ECRREE(XFLOT)
  632. RETURN
  633. ENDIF
  634. MOTERR(1:4)=CMOT
  635. MOTERR(5:12)='CHPOINT'
  636. INTERR(1)=MPOINT
  637. CALL ERREUR(65)
  638. RETURN
  639. ENDIF
  640.  
  641.  
  642.  
  643. * +-------------------------------------------------------------------+
  644. * | |
  645. * | M C H A M L |
  646. * | |
  647. * +-------------------------------------------------------------------+
  648. ELSE IF (CTYP.EQ.'MCHAML') THEN
  649. CALL LIROBJ('MCHAML',IPCHE1,1,IRET)
  650. IF (IERR.NE.0) RETURN
  651. C
  652. CALL LIRCHA(CMOT,1,IRET0)
  653. IF (IERR.NE.0) RETURN
  654.  
  655.  
  656. * ================================================
  657. * MOTS-CLES "DEVA" OU "COVA" => NOMS DES VARIABLES
  658. * ================================================
  659. IF (CMOT.EQ.'DEVA'.OR.CMOT.EQ.'COVA') THEN
  660. CALL EXCHA1(IPCHE1,ILISR,CMOT)
  661. IF (ILISR.NE.0) CALL ECROBJ('LISTMOTS',ILISR)
  662. RETURN
  663.  
  664. * =================================
  665. * MOT-CLE "NBZO" => NOMBRE DE ZONES
  666. * =================================
  667. ELSE IF (CMOT.EQ.'NBZO') THEN
  668. CALL EXTR18(IPCHE1,NBZONE)
  669. if (ierr.ne.0) return
  670. CALL ECRENT(NBZONE)
  671. RETURN
  672.  
  673. * =====================================================
  674. * MOT-CLE "COMP" => EXTRACTION DES NOMS DES COMPOSANTES
  675. * =====================================================
  676. ELSE IF (CMOT.EQ.'COMP' ) THEN
  677. CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  678. C
  679. C RECHERCHE DES NOMS DES COMPOSANTES APPARTENANT
  680. C A LA ZONE DU MODELE
  681. IF (IRETM.NE.0) THEN
  682. CALL EXTR15(IPMODL,IPCHE1,IPLSTM)
  683. IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  684. RETURN
  685. C
  686. C RECHERCHE DES NOMS DE TOUTES LES COMPOSANTES
  687. ELSE
  688. CALL EXTR17(IPCHE1,IPLSTM)
  689. CALL ECROBJ('LISTMOTS',IPLSTM)
  690. RETURN
  691. ENDIF
  692.  
  693. * ======================================================
  694. * MOT-CLE "CONS" => EXTRACTION DES NOMS DES CONSTITUANTS
  695. * ======================================================
  696. ELSE IF(CMOT.EQ.'CONS' ) THEN
  697. CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  698. C
  699. C RECHERCHE DES NOMS DES CONSTITUANTS APPARTENANT
  700. C A LA ZONE DU MODELE
  701. IF (IRETM.NE.0) THEN
  702. CALL EXTR35(IPMODL,IPCHE1,IPLSTM)
  703. IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  704. RETURN
  705. C
  706. C RECHERCHE DES NOMS DE TOUs LES constituants
  707. ELSE
  708. CALL EXTR37(IPCHE1,IPLSTM)
  709. CALL ECROBJ('LISTMOTS',IPLSTM)
  710. RETURN
  711. ENDIF
  712.  
  713. * =========================================================
  714. * EXTRACTION DE LA VALEUR, DU TITRE, DU TYPE OU DU MAILLAGE
  715. * =========================================================
  716. ELSE
  717. IF (CMOT.NE.'TITR'.AND.CMOT.NE.'TYPE'.AND.CMOT.NE.'MAIL')
  718. $ THEN
  719. CALL LIRENT(IENT1,1,IRET1)
  720. IF(IRET1.EQ.0) RETURN
  721. CALL LIRENT(IENT2,1,IRET2)
  722. IF(IRET2.EQ.0) RETURN
  723. CALL LIRENT(IENT3,1,IRET3)
  724. IF(IRET3.EQ.0) RETURN
  725. ENDIF
  726. CALL EXTR14(IPCHE1,IENT1,IENT2,IENT3,CMOT)
  727. RETURN
  728. ENDIF
  729.  
  730.  
  731. * +-------------------------------------------------------------------+
  732. * | |
  733. * | M M O D E L |
  734. * | |
  735. * +-------------------------------------------------------------------+
  736. ELSE IF (CTYP.EQ.'MMODEL') THEN
  737. CALL LIROBJ('MMODEL',IPMODL,1,IRET)
  738. IF (IERR.NE.0) RETURN
  739. CALL LIRMOT(CMOC,20,IRET,1)
  740. IF(IERR.NE.0) RETURN
  741. CMOT=CMOC(IRET)
  742. MMODEL=IPMODL
  743. SEGACT MMODEL
  744. NSOUS=KMODEL(/1)
  745. C en cas de modele melange derouler : creer un nouveau mmode
  746. segini limode
  747. do im = 1,NSOUS
  748. imodel = kmodel(im)
  749. segact imodel
  750. limode(**) = imodel
  751. if (formod(1).eq.'MELANGE') then
  752. if (ivamod(/1).ge.1) then
  753. do ivm1 = 1,ivamod(/1)
  754. if (tymode(ivm1).eq.'IMODEL') then
  755. limode(**) = ivamod(ivm1)
  756. endif
  757. enddo
  758. endif
  759. endif
  760. enddo
  761. segdes mmodel
  762. C test non redondance
  763. N1 = 1
  764. if (limode(/1).gt.1) then
  765. do 1161 it1 = limode(/1),2,-1
  766. imode1 = limode(it1)
  767. segact imode1
  768. do it2 = (it1 - 1) ,1,-1
  769. imode2 = limode(it2)
  770. segact imode2
  771. if (imode1.imamod.eq.imode2.imamod.and.
  772. & imode1.conmod.eq.imode2.conmod) then
  773. limode(it1) = 0
  774. goto 1161
  775. endif
  776. enddo
  777. N1 = N1 + 1
  778. 1161 continue
  779. endif
  780. is1 = 0
  781. if (limode(/1).gt.0) then
  782. segini,mmodel
  783. do is = 1,limode(/1)
  784. if (limode(is).gt.0) then
  785. is1 = is1 + 1
  786. kmodel(is1) = limode(is)
  787. endif
  788. enddo
  789. else
  790. endif
  791. NSOUS=KMODEL(/1)
  792. IPMODL = MMODEL
  793.  
  794. IF (CMOT.EQ.'MAIL') THEN
  795. MMODEL=IPMODL
  796. SEGACT MMODEL
  797. NSOUS=KMODEL(/1)
  798. IF (KMODEL(/1) .GT. 0) THEN
  799. C Cas du MODELE non VIDE
  800. IMODEL=KMODEL(1)
  801. SEGACT IMODEL
  802. IPP1=IMAMOD
  803. SEGDES IMODEL
  804. IF(NSOUS .GT. 1) THEN
  805. DO 1116 I=2,NSOUS
  806. IMODEL=KMODEL(I)
  807. SEGACT IMODEL
  808. IPP2 = IMAMOD
  809. SEGDES IMODEL
  810. ltelq=.false.
  811. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  812. IPP1=IRET
  813. 1116 CONTINUE
  814. ENDIF
  815. ELSE
  816. C Cas du MODELE VIDE ==> MAILLAGE VIDE
  817. NBELEM=0
  818. NBNN =NBNNE(ILCOUR)
  819. NBREF =0
  820. NBSOUS=0
  821. SEGINI MELEME
  822. ITYPEL = ILCOUR
  823. IPP1 = MELEME
  824. SEGDES,MELEME
  825. ENDIF
  826. SEGDES MMODEL
  827. CALL ECROBJ('MAILLAGE',IPP1)
  828. RETURN
  829.  
  830. ELSEIF (CMOT.eq.'COMP') THEN
  831. CALL LIRCHA(MOFORM(1),1,iretou)
  832. if(ierr.ne.0) return
  833. MMODEL=IPMODL
  834. SEGACT MMODEL
  835. NSOUS=KMODEL(/1)
  836. segini,MMODE1=MMODEL
  837. N1=0
  838. DO 5497 I=1,NSOUS
  839. IMODEL=KMODEL(I)
  840. SEGACT IMODEL
  841. DO IB=1,MATMOD(/2)
  842. IF( MATMOD(IB).EQ.MOFORM(1)) go to 5498
  843. ENDDO
  844. SEGDES IMODEL
  845. GO TO 5497
  846. 5498 CONTINUE
  847. N1=N1+1
  848. MMODE1.KMODEL(N1)=KMODEL(I)
  849. SEGDES IMODEL
  850. 5497 CONTINUE
  851. SEGDES MMODEL
  852. IF(N1.EQ.0)CALL ERREUR(610)
  853. IF(N1.GE.0.AND.N1.NE.NSOUS) SEGADJ MMODE1
  854. segdes MMODE1
  855. CALL ECROBJ('MMODEL',MMODE1)
  856. RETURN
  857.  
  858. ELSEIF(CMOT.EQ.'OBJE') THEN
  859. mmodel=ipmodl
  860. segact mmodel
  861. if(kmodel(/1).ne.1) then
  862. WRITE(IOIMP,*) ' Dans extrai.eso : '
  863. WRITE(IOIMP,*) ' ce n est pas un modele elementaire'
  864. WRITE(IOIMP,*) ' it is not an elementary model'
  865. call erreur(19)
  866. return
  867. endif
  868. imodel=kmodel(1)
  869. segact imodel
  870. iob=ivamod(/1)
  871. do io=iob,1,-1
  872. ctyp=tymode(io)
  873. if( ctyp.eq.'ENTIER') then
  874. call ecrent(ivamod(io))
  875. else
  876. call ecrobj(ctyp,ivamod(io))
  877. endif
  878. enddo
  879. segdes imodel,mmodel
  880. return
  881.  
  882. ELSEIF (CMOT.EQ.'ZONE') THEN
  883. MMODEL=IPMODL
  884. SEGACT MMODEL
  885. NSOUS=KMODEL(/1)
  886. M=NSOUS*2
  887. N1 = 1
  888. SEGINI MTABLE
  889. IF(NSOUS.NE.0) THEN
  890. DO 128 IOK=1,NSOUS
  891. IMODEL=KMODEL(IOK)
  892. SEGACT IMODEL
  893. NFOR=FORMOD(/2)
  894. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  895. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  896. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  897. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  898. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  899. SEGINI,IMODE1= IMODEL
  900. IMODE1.INFMOD(2)=0
  901. SEGDES IMODEL
  902. IMODEL=IMODE1
  903. ENDIF
  904. SEGINI MMODE1
  905. MMODE1.KMODEL(1) = IMODEL
  906. SEGDES MMODE1
  907. IPP1= MMODE1
  908. IPP2=IMAMOD
  909. IVALI1=IOK*2 -1
  910. IVALI2=IOK*2
  911. CALL ECCTAB(MTABLE,'ENTIER ',IVALI1,XFLOT,MOT_8,LAG,
  912. $ IOBIN,'MMODEL ',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  913. CALL ECCTAB(MTABLE,'ENTIER ',IVALI2,XFLOT,MOT_8,LAG,
  914. $ IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP2)
  915. SEGDES IMODEL
  916. 128 CONTINUE
  917. ENDIF
  918. CALL ECROBJ('TABLE ',MTABLE)
  919. RETURN
  920.  
  921. ELSE IF (CMOT.EQ.'FORM'.OR.CMOT.EQ.'CONS'.OR.CMOT.EQ.'ELEM'.OR.
  922. $ CMOT.EQ.'MATE') THEN
  923. INFOR=1
  924. IF (CMOT.EQ.'MATE') THEN
  925. IPASS=0
  926. ICOND=0
  927. 1191 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  928. IF (IERR.NE.0) RETURN
  929. IPASS=IPASS+1
  930. IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN
  931. CALL NOVARD(IPMODL,CMOT)
  932. RETURN
  933. ENDIF
  934. IF (IRETO.NE.0) THEN
  935. INFOR=INFOR+1
  936. IF (INFOR.GT.NBFORM) THEN
  937. CALL ERREUR(5)
  938. RETURN
  939. ENDIF
  940. GO TO 1191
  941. ENDIF
  942. ELSE
  943. ICOND=1
  944. 1192 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  945. IF (IERR.NE.0) RETURN
  946. ICOND=0
  947. IF (IRETO.NE.0) THEN
  948. INFOR=INFOR+1
  949. IF (INFOR.GT.NBFORM) THEN
  950. CALL ERREUR(5)
  951. RETURN
  952. ENDIF
  953. GO TO 1192
  954. ENDIF
  955. ENDIF
  956. INFOR=INFOR-1
  957. C
  958. MMODE1=IPMODL
  959. SEGACT MMODE1
  960. NSOUS=MMODE1.KMODEL(/1)
  961. N1=NSOUS
  962. SEGINI MMODEL
  963. IPP1=MMODEL
  964. NZON=0
  965. C
  966. C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  967. C partie
  968. IF (NSOUS .EQ. 0) THEN
  969. SEGDES MMODEL
  970. SEGDES MMODE1
  971. CALL ECROBJ('MMODEL',IPP1)
  972. RETURN
  973. ELSE
  974. DO 1119 I=1,NSOUS
  975. IMODEL=MMODE1.KMODEL(I)
  976. SEGACT IMODEL
  977. IF(CMOT.EQ.'FORM') THEN
  978. NFOR=FORMOD(/2)
  979.  
  980. IF(NFOR.NE.INFOR) GO TO 1119
  981. IF(NFOR.EQ.1) THEN
  982. IF(MOFORM(1).NE.FORMOD(1)) GO TO 1119
  983. ELSE IF(NFOR.EQ.2) THEN
  984. IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE.
  985. $ FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND.
  986. $ (MOFORM(2).NE.FORMOD(1))))GO TO 1119
  987. ELSE
  988. GO TO 1118
  989. ENDIF
  990. ELSE IF (CMOT.EQ.'CONS') THEN
  991. DO 425 IJ=1,INFOR
  992. C on enleve les espaces au debut et a la fin
  993. idim0=LEN(MOFORM(IJ))
  994. idim1=CONMOD(/1)
  995. ideb0=0
  996. ifin0=0
  997. ideb1=0
  998. ifin1=0
  999. DO ii=1,idim0
  1000. IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ')
  1001. $ ideb0=ii
  1002. IF(ifin0.EQ.0.AND.
  1003. & MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ')
  1004. & ifin0=idim0-ii+1
  1005. ENDDO
  1006. DO ii=1,idim1
  1007. IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii
  1008. IF(ifin1.EQ.0.AND.
  1009. & CONMOD(idim1-ii+1:idim1-ii+1).NE.' ')
  1010. & ifin1=idim1-ii+1
  1011. ENDDO
  1012. C print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1
  1013. IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1))
  1014. & GOTO 429
  1015. 425 CONTINUE
  1016. GO TO 1119
  1017. ELSE IF (CMOT.EQ.'ELEM') THEN
  1018. DO 426 IJ=1,INFOR
  1019. IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GO TO 429
  1020. 426 CONTINUE
  1021. GO TO 1119
  1022. ELSEIF(CMOT.EQ.'MATE') THEN
  1023. NMAT=MATMOD(/2)
  1024. DO 427 IJ=1,INFOR
  1025. DO 4275 JJ=1,NMAT
  1026. IF(MATMOD(JJ).EQ.MOFORM(IJ)) GO TO 429
  1027. 4275 CONTINUE
  1028. 427 CONTINUE
  1029. GO TO 1119
  1030. ENDIF
  1031. C on vient ici pour prendre les sous modeles
  1032. 429 CONTINUE
  1033. NZON=NZON+1
  1034. NFOR=FORMOD(/2)
  1035. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  1036. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  1037. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  1038. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  1039. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  1040. SEGINI,IMODE1= IMODEL
  1041. IMODE1.INFMOD(2)=0
  1042. SEGDES IMODEL
  1043. IMODEL=IMODE1
  1044. ENDIF
  1045. KMODEL(NZON)=IMODEL
  1046. SEGDES IMODEL
  1047. 1119 CONTINUE
  1048. ENDIF
  1049. C
  1050. IF(NZON.EQ.0) GO TO 1118
  1051. N1=NZON
  1052. SEGADJ MMODEL
  1053. SEGDES MMODEL
  1054. SEGDES MMODE1
  1055. CALL ECROBJ('MMODEL',IPP1)
  1056. RETURN
  1057. 1118 CONTINUE
  1058. CALL ERREUR(610)
  1059. SEGSUP MMODEL
  1060. SEGDES IMODEL
  1061. SEGDES MMODE1
  1062. RETURN
  1063.  
  1064. ELSE IF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN
  1065. CALL NOVARD(IPMODL,CMOT)
  1066. RETURN
  1067.  
  1068. ELSE
  1069. MOTERR(1:4)=CMOT
  1070. CALL ERREUR(7)
  1071. RETURN
  1072. ENDIF
  1073.  
  1074.  
  1075. * +-------------------------------------------------------------------+
  1076. * | |
  1077. * | C H A R G E M E N T |
  1078. * | |
  1079. * +-------------------------------------------------------------------+
  1080. ELSE IF (CTYP.EQ.'CHARGEME') THEN
  1081. CALL LIROBJ('CHARGEME',ICHAR,1,IRET)
  1082. IF (IERR.NE.0) RETURN
  1083. C
  1084. CMOT = ' '
  1085. ICHGT = 0
  1086. LCHGT = 0
  1087. IEC = 1
  1088. CALL LIROBJ('LISTMOTS',LCHGT,0,IRET)
  1089. IF (IERR.NE.0) RETURN
  1090. IF (IRET.EQ.0) THEN
  1091. CALL LIRCHA(CMOT,1,IRETOU)
  1092. IF (IERR.NE.0) RETURN
  1093. CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT)
  1094. IF (ICHGT.GE.1 .AND. ICHGT.LE.5) THEN
  1095. CALL LIRENT(IEC,0,IRETOU)
  1096. IF (IERR.NE.0) RETURN
  1097. IF (IRETOU.EQ.0) IEC = 1
  1098. ELSE IF (ICHGT.EQ.0) THEN
  1099. CALL LIRCHA(MOT_4,0,IRETOU)
  1100. IF (IRETOU.NE.0) THEN
  1101. IF (MOT_4.EQ.'TABL') THEN
  1102. ICHGT=-1
  1103. ELSE
  1104. CALL REFUS
  1105. ENDIF
  1106. ENDIF
  1107. ENDIF
  1108. ENDIF
  1109. C
  1110. CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8)
  1111. C
  1112. IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1)
  1113. IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2)
  1114. RETURN
  1115.  
  1116.  
  1117. * +-------------------------------------------------------------------+
  1118. * | |
  1119. * | L I S T C H P O |
  1120. * | |
  1121. * +-------------------------------------------------------------------+
  1122. ELSE IF (CTYP.EQ.'LISTCHPO') THEN
  1123. CALL LIROBJ('LISTCHPO',ILCHP1,1,IRET)
  1124. IF (IERR.NE.0) RETURN
  1125. CALL QUETYP(CTYP1,0,IRETOU)
  1126. IF (IRETOU.EQ.0) THEN
  1127. CALL ERREUR(533)
  1128. RETURN
  1129. ENDIF
  1130.  
  1131. MLCHP1 = ILCHP1
  1132. SEGACT , MLCHP1
  1133. LONCHP = MLCHP1.ICHPOI(/1)
  1134.  
  1135. * ===============================
  1136. * EXTRACTION DE PLUSIEURS INDICES
  1137. * ===============================
  1138. IF (CTYP1.EQ.'LISTENTI') THEN
  1139. CALL LIROBJ('LISTENTI',ILENT,1,IRET)
  1140. IF (IERR.NE.0) GOTO 1212
  1141. MLENTI = ILENT
  1142. SEGACT,MLENTI
  1143. JG = LECT(/1)
  1144. N1=JG
  1145. SEGINI,MLCHP2
  1146. ILCHP2= MLCHP2
  1147. DO 1211 I=1 , JG
  1148. IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN
  1149. INTERR(1) = LECT(I)
  1150. CALL ERREUR(620)
  1151. ENDIF
  1152. MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I))
  1153. 1211 CONTINUE
  1154. SEGDES,MLENTI
  1155. SEGDES,MLCHP1
  1156. SEGDES,MLCHP2
  1157. CALL ECROBJ ('LISTCHPO',ILCHP2)
  1158. RETURN
  1159.  
  1160. * ===========================
  1161. * EXTRACTION D'UN SEUL INDICE
  1162. * ===========================
  1163. ELSEIF (CTYP1.EQ.'ENTIER') THEN
  1164. CALL LIRENT(ILENT,1,IRETOU)
  1165. IF (IERR.NE.0) GOTO 1212
  1166. IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN
  1167. INTERR(1)=ILENT
  1168. CALL ERREUR(620)
  1169. ENDIF
  1170. ILCHPO = MLCHP1.ICHPOI(ILENT)
  1171. SEGDES,MLCHP1
  1172. CALL ECROBJ('CHPOINT ',ILCHPO)
  1173. RETURN
  1174.  
  1175. * ====================================================
  1176. * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN UN POINT
  1177. * ====================================================
  1178. ELSEIF (CTYP1.EQ.'MOT') THEN
  1179. CALL LIRCHA(CMOT,1,IRETOU)
  1180. IF (IERR.NE.0) GOTO 1212
  1181. IF (CMOT.NE.'VALE') THEN
  1182. MOTERR(1:4) = 'VALE'
  1183. CALL ERREUR(396)
  1184. GOTO 1212
  1185. ENDIF
  1186. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  1187. IF (IRETOU.EQ.0) THEN
  1188. CALL LIRCHA(MOT_4,0,IRETOU)
  1189. IF (IRETOU.GT.0) THEN
  1190. JGN=4
  1191. JGM=1
  1192. SEGINI,MLMOTS
  1193. MOTS(1)=MOT_4
  1194. SEGDES,MLMOTS
  1195. ENDIF
  1196. ENDIF
  1197. CALL LIROBJ('POINT',MPOINT,1,IRETOU)
  1198. IF (IERR.NE.0) GOTO 1212
  1199. CALL EXTR24(MLCHP1,MLMOTS,MPOINT,MLREEL)
  1200. IF (IERR.NE.0) RETURN
  1201. SEGDES,MLCHP1
  1202. SEGDES,MLREEL
  1203. CALL ECROBJ('LISTREEL',MLREEL)
  1204. RETURN
  1205.  
  1206. * SYNTAXE INCORRECTE
  1207. ELSE
  1208. MOTERR(1:40) = 'ENTIER LISTENTI"VALE"'
  1209. CALL ERREUR(471)
  1210. GOTO 1212
  1211. ENDIF
  1212. C
  1213. C (erreur lors du traitement du LISTCHPO)
  1214. C
  1215. 1212 SEGDES,MLCHP1
  1216. RETURN
  1217.  
  1218.  
  1219. * +-------------------------------------------------------------------+
  1220. * | |
  1221. * | N U A G E |
  1222. * | |
  1223. * +-------------------------------------------------------------------+
  1224. ELSE IF (CTYP.EQ.'NUAGE') THEN
  1225. CALL LIROBJ('NUAGE ',IPOINT,1,IRET)
  1226. IF (IERR.NE.0) RETURN
  1227.  
  1228. MNUAGE=IPOINT
  1229. SEGACT MNUAGE
  1230. CALL LIRMOT(NUMO,5,INU1,0)
  1231. IF (INU1.EQ.0) THEN
  1232. CALL LIRCHA(CTYP1,1,IRETOU)
  1233. IF (IERR.NE.0) THEN
  1234. SEGDES MNUAGE
  1235. RETURN
  1236. ENDIF
  1237. CALL LIRMOT(NUMO,5,INU1,0)
  1238. IF (INU1.EQ.0) THEN
  1239. IF (CTYP1.EQ.'COMP ') THEN
  1240. IPROG = 1
  1241. ELSE
  1242. IPOSI = 0
  1243. DO 1250 I=1,NUANOM(/2)
  1244. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1245. 1250 CONTINUE
  1246. IF (IPOSI.EQ.0) THEN
  1247. SEGDES MNUAGE
  1248. MOTERR(1:8) = CTYP1
  1249. C TYP1 n'est pas un nom de variable du NUAGE
  1250. CALL ERREUR(672)
  1251. RETURN
  1252. ENDIF
  1253. IPROG = 2
  1254. ENDIF
  1255. ELSE
  1256. IPOSI = 0
  1257. DO 1251 I=1,NUANOM(/2)
  1258. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1259. 1251 CONTINUE
  1260. IF (IPOSI.EQ.0) THEN
  1261. SEGDES MNUAGE
  1262. MOTERR(1:8) = CTYP1
  1263. C TYP1 n'est pas un nom de variable du NUAGE
  1264. CALL ERREUR(672)
  1265. RETURN
  1266. ENDIF
  1267. IPROG = 3
  1268. ENDIF
  1269. ELSE
  1270. CALL LIRCHA(CTYP1,1,IRETOU)
  1271. IF (IERR.NE.0) THEN
  1272. SEGDES MNUAGE
  1273. RETURN
  1274. ENDIF
  1275. IPOSI = 0
  1276. DO 1252 I=1,NUANOM(/2)
  1277. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1278. 1252 CONTINUE
  1279. IF (IPOSI.EQ.0) THEN
  1280. SEGDES,MNUAGE
  1281. MOTERR(1:8) = CTYP1
  1282. C TYP1 n'est pas un nom de variable du NUAGE
  1283. CALL ERREUR(672)
  1284. RETURN
  1285. ELSE
  1286. IPROG = 3
  1287. ENDIF
  1288. ENDIF
  1289.  
  1290. C-------------- Lecture eventuelle des FLOTTANTS -------------
  1291. IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN
  1292. IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN
  1293. CALL LIRREE(XVAL1,0,IRETOU)
  1294. IF (IRETOU.EQ.0) THEN
  1295. SEGDES,MNUAGE
  1296. C Il manque la valeur de la composante reelle
  1297. CALL ERREUR(668)
  1298. RETURN
  1299. ENDIF
  1300. ELSE
  1301. CALL LIRREE(XVAL1,0,IRETO1)
  1302. CALL LIRREE(XVAL2,0,IRETO2)
  1303. IF ((IRETO1.EQ.0).OR.(IRETO2.EQ.0)) THEN
  1304. SEGDES,MNUAGE
  1305. C Il faut specifier deux valeurs reelles
  1306. CALL ERREUR(673)
  1307. RETURN
  1308. ENDIF
  1309. ENDIF
  1310. ENDIF
  1311. SEGDES MNUAGE
  1312.  
  1313. C--------- Cas de l'extraction des noms des composantes du NUAGE -------
  1314. IF (IPROG.EQ.1) THEN
  1315. CALL EXTR19(IPOINT,IPLSTM)
  1316. IF (IPLSTM.NE.0) THEN
  1317. CALL ECROBJ('LISTMOTS',IPLSTM)
  1318. ENDIF
  1319.  
  1320. C----Cas de l'extraction de l'objet correspondant a une composante ---
  1321. C----------------- donnee d'un NUAGE "colonne" -----------------------
  1322.  
  1323. ELSE IF (IPROG.EQ.2) THEN
  1324. CALL EXTR51(IPOINT,IPOSI)
  1325.  
  1326. C---------------------------- Autres cas ------------------------------
  1327. ELSE IF (IPROG.EQ.3) THEN
  1328. IF (INU1.EQ.1) THEN
  1329. BORINF=.TRUE.
  1330. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1331. ELSE IF (INU1.EQ.2) THEN
  1332. BORINF=.FALSE.
  1333. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1334. ELSE IF (INU1.EQ.3) THEN
  1335. MINI =.TRUE.
  1336. CALL EXTR52(IPOINT,MINI,IPOSI)
  1337. ELSE IF (INU1.EQ.4) THEN
  1338. MINI =.FALSE.
  1339. CALL EXTR52(IPOINT,MINI,IPOSI)
  1340. ELSE IF (INU1.EQ.5) THEN
  1341. CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
  1342. ELSE
  1343. CALL ERREUR(21)
  1344. RETURN
  1345. ENDIF
  1346.  
  1347. C---------------------------- Cas non prevus ---------------------------
  1348. ELSE
  1349. CALL ERREUR(21)
  1350. RETURN
  1351. ENDIF
  1352. RETURN
  1353.  
  1354. ENDIF
  1355.  
  1356.  
  1357. ***********************************************************************
  1358. * ON TRAITE LES LISTENTI, LISTREEL ET LISTMOTS SEPAREMENT POUR *
  1359. * POUVOIR TOLERER L'INVERSION DES DEUX ARGUMENTS (LA LISTE PRINCIPALE *
  1360. * ET L'INDICE/LA LISTE D'INDICES) *
  1361. ***********************************************************************
  1362.  
  1363.  
  1364. * +-------------------------------------------------------------------+
  1365. * | |
  1366. * | L I S T M O T S |
  1367. * | |
  1368. * +-------------------------------------------------------------------+
  1369. 10 CONTINUE
  1370. CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET)
  1371. IF (IRET.EQ.0) GOTO 20
  1372.  
  1373. MLMOT1 = ILMOT1
  1374. SEGACT , MLMOT1
  1375. LONMOT = MLMOT1.MOTS(/2)
  1376. JGN = MLMOT1.MOTS(/1)
  1377.  
  1378. * ===============================
  1379. * EXTRACTION DE PLUSIEURS INDICES
  1380. * ===============================
  1381. CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1382. IF ( IRET .EQ. 1 ) THEN
  1383. MLENTI = ILENT
  1384. SEGACT , MLENTI
  1385. JGM = LECT(/1)
  1386. SEGINI , MLMOT2
  1387. ILMOT2= MLMOT2
  1388. DO 1221 I=1 , JGM
  1389. IF (( LECT(I) .GT. LONMOT ) .OR. ( LECT(I) .LT. 1 )) THEN
  1390. INTERR(1) = LECT(I)
  1391. CALL ERREUR(620)
  1392. ENDIF
  1393. MLMOT2.MOTS(I) = MLMOT1.MOTS(LECT(I))
  1394. 1221 CONTINUE
  1395. SEGDES , MLENTI
  1396. SEGDES , MLMOT1
  1397. SEGDES , MLMOT2
  1398. CALL ECROBJ ('LISTMOTS',ILMOT2)
  1399. RETURN
  1400.  
  1401. * ===========================
  1402. * EXTRACTION D'UN SEUL INDICE
  1403. * ===========================
  1404. ELSE
  1405. CALL LIRENT (ILENT,1,IRETOU)
  1406. IF (IERR .NE. 0) THEN
  1407. SEGDES , MLMOT1
  1408. RETURN
  1409. ENDIF
  1410. IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN
  1411. INTERR(1)=ILENT
  1412. CALL ERREUR(620)
  1413. ELSE
  1414. CTEXT = MLMOT1.MOTS(ILENT)
  1415. ENDIF
  1416. SEGDES , MLMOT1
  1417. CALL ECRCHA(CTEXT(1:JGN))
  1418. RETURN
  1419. ENDIF
  1420.  
  1421.  
  1422. * +-------------------------------------------------------------------+
  1423. * | |
  1424. * | L I S T R E E L |
  1425. * | |
  1426. * +-------------------------------------------------------------------+
  1427. 20 CONTINUE
  1428. CALL LIROBJ('LISTREEL',ILREE1,0,IRET)
  1429. IF (IRET.EQ.0) GOTO 30
  1430.  
  1431. MLREE1 = ILREE1
  1432. SEGACT , MLREE1
  1433. LONREE = MLREE1.PROG(/1)
  1434.  
  1435. * ===============================
  1436. * EXTRACTION DE PLUSIEURS INDICES
  1437. * ===============================
  1438. CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1439. IF ( IRET .EQ. 1 ) THEN
  1440. MLENTI = ILENT
  1441. SEGACT , MLENTI
  1442. JG = LECT(/1)
  1443. SEGINI , MLREE2
  1444. ILREE2= MLREE2
  1445. DO 1231 I=1 , JG
  1446. IF (( LECT(I) .GT. LONREE ) .OR. ( LECT(I) .LT. 1 )) THEN
  1447. INTERR(1) = LECT(I)
  1448. CALL ERREUR(620)
  1449. ENDIF
  1450. MLREE2.PROG(I) = MLREE1.PROG(LECT(I))
  1451. 1231 CONTINUE
  1452. SEGDES , MLENTI
  1453. SEGDES , MLREE1
  1454. SEGDES , MLREE2
  1455. CALL ECROBJ ('LISTREEL',ILREE2)
  1456. RETURN
  1457.  
  1458. * ===========================
  1459. * EXTRACTION D'UN SEUL INDICE
  1460. * ===========================
  1461. ELSE
  1462. CALL LIRENT (ILENT,1,IRETOU)
  1463. IF (IERR .NE. 0) THEN
  1464. SEGDES , MLREE1
  1465. RETURN
  1466. ENDIF
  1467. IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN
  1468. INTERR(1)=ILENT
  1469. CALL ERREUR(620)
  1470. ELSE
  1471. REELDP = MLREE1.PROG(ILENT)
  1472. ENDIF
  1473. SEGDES , MLREE1
  1474. CALL ECRREE(REELDP)
  1475. RETURN
  1476. ENDIF
  1477. 124 CONTINUE
  1478.  
  1479.  
  1480. * +-------------------------------------------------------------------+
  1481. * | |
  1482. * | L I S T E N T I |
  1483. * | |
  1484. * +-------------------------------------------------------------------+
  1485. 30 CONTINUE
  1486. CALL LIROBJ('LISTENTI',ILENT1,0,IRET)
  1487. IF (IRET.EQ.0) GOTO 999
  1488.  
  1489. MLENT1 = ILENT1
  1490. SEGACT , MLENT1
  1491. LONENT = MLENT1.LECT(/1)
  1492.  
  1493. * ===============================
  1494. * EXTRACTION DE PLUSIEURS INDICES
  1495. * ===============================
  1496. CALL LIROBJ('LISTENTI',ILENT2,0,IRET)
  1497. IF ( IRET .EQ. 1 ) THEN
  1498. MLENT2 = ILENT2
  1499. SEGACT , MLENT2
  1500. JG = MLENT2.LECT(/1)
  1501. SEGINI , MLENT3
  1502. ILENT3= MLENT3
  1503. DO 1241 I=1 , JG
  1504. IF (MLENT2.LECT(I).GT.LONENT.OR.MLENT2.LECT(I).LT.1) THEN
  1505. INTERR(1) = MLENT2.LECT(I)
  1506. CALL ERREUR(620)
  1507. ENDIF
  1508. MLENT3.LECT(I) = MLENT1.LECT(MLENT2.LECT(I))
  1509. 1241 CONTINUE
  1510. SEGDES , MLENT1
  1511. SEGDES , MLENT2
  1512. SEGDES , MLENT3
  1513. CALL ECROBJ ('LISTENTI',ILENT3)
  1514. RETURN
  1515.  
  1516. * ===========================
  1517. * EXTRACTION D'UN SEUL INDICE
  1518. * ===========================
  1519. ELSE
  1520. CALL LIRENT (ILENT,1,IRETOU)
  1521. IF (IERR .NE. 0) THEN
  1522. SEGDES , MLENT1
  1523. RETURN
  1524. ENDIF
  1525. IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN
  1526. INTERR(1)=ILENT
  1527. CALL ERREUR(620)
  1528. ELSE
  1529. INTEGR = MLENT1.LECT(ILENT)
  1530. ENDIF
  1531. SEGDES , MLENT1
  1532. CALL ECRENT(INTEGR)
  1533. RETURN
  1534. ENDIF
  1535.  
  1536.  
  1537.  
  1538.  
  1539. * +-------------------------------------------------------------------+
  1540. * | E R R E U R : P A S D ' O B J E T C O M P A T I B L E |
  1541. * +-------------------------------------------------------------------+
  1542. 999 CONTINUE
  1543. CALL ERREUR(676)
  1544.  
  1545.  
  1546.  
  1547.  
  1548. RETURN
  1549. END
  1550.  
  1551.  
  1552.  
  1553.  
  1554.  
  1555.  
  1556.  
  1557.  
  1558.  
  1559.  
  1560.  
  1561.  
  1562.  

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