Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

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

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