Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTRAI SOURCE CB215821 20/07/29 21:15:29 10668
  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.  
  749. C Extension du MMODEL en cas de modele de MELANGE
  750. CALL MODETE(IPMODL,MMODEL,IMELAN)
  751. NSOUS=MMODEL.KMODEL(/1)
  752.  
  753. IF (CMOT.EQ.'MAIL') THEN
  754. IMFRO=.FALSE.
  755. CALL LIRMOT(CFROT,1,IRET,0)
  756. IF (IRET.EQ.1) THEN
  757. IMFRO=.TRUE.
  758. ENDIF
  759. IF (NSOUS .GT. 0) THEN
  760. C Cas du MODELE non VIDE
  761. IMODEL=KMODEL(1)
  762. IF (IMFRO) THEN
  763. NMATT=MATMOD(/2)
  764. CALL PLACE(MATMOD,NMATT,IPLAC,'FROTTANT')
  765. IF (IPLAC.EQ.0) THEN
  766. CALL ERREUR(26)
  767. RETURN
  768. ENDIF
  769. IPP1=IVAMOD(1)
  770. ELSE
  771. IPP1=IMAMOD
  772. ENDIF
  773. IF(NSOUS .GT. 1) THEN
  774. DO 1116 I=2,NSOUS
  775. IMODEL= KMODEL(I)
  776. IPP2 = IMAMOD
  777. ltelq =.false.
  778. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  779. IPP1=IRET
  780. 1116 CONTINUE
  781. ENDIF
  782. ELSE
  783. C Cas du MODELE VIDE ==> MAILLAGE VIDE
  784. NBELEM = 0
  785. NBNN = NBNNE(ILCOUR)
  786. NBREF = 0
  787. NBSOUS = 0
  788. SEGINI,MELEME
  789. ITYPEL = ILCOUR
  790. IPP1 = MELEME
  791. ENDIF
  792. CALL ACTOBJ('MAILLAGE',IPP1,1)
  793. CALL ECROBJ('MAILLAGE',IPP1)
  794. RETURN
  795.  
  796. ELSEIF (CMOT.eq.'COMP') THEN
  797. CALL LIRCHA(MOFORM(1),1,iretou)
  798. if(ierr.ne.0) return
  799. N1=0
  800. SEGINI,MMODE1
  801. DO 5497 I=1,NSOUS
  802. IMODEL=KMODEL(I)
  803. DO IB=1,MATMOD(/2)
  804. IF( MATMOD(IB) .EQ. MOFORM(1) ) GOTO 5498
  805. ENDDO
  806. GOTO 5497
  807. 5498 CONTINUE
  808. N1=N1+1
  809. MMODE1.KMODEL(**)=KMODEL(I)
  810. 5497 CONTINUE
  811.  
  812. IF(N1.GE.0.AND.N1.LT.NSOUS) THEN
  813. SEGADJ,MMODE1
  814.  
  815. ELSEIF(N1.EQ.NSOUS)THEN
  816. C Pas la peine de creer un autre MMODEL
  817. SEGSUP,MMODE1
  818. MMODE1=MMODEL
  819.  
  820. ELSE
  821. CALL ERREUR(5)
  822. ENDIF
  823.  
  824. CALL ACTOBJ('MMODEL ',MMODE1,1)
  825. CALL ECROBJ('MMODEL ',MMODE1)
  826. RETURN
  827.  
  828. ELSEIF(CMOT.EQ.'OBJE') THEN
  829. if(NSOUS.ne.1) then
  830. WRITE(IOIMP,*) ' Dans extrai.eso : '
  831. WRITE(IOIMP,*) ' ce n est pas un modele elementaire'
  832. WRITE(IOIMP,*) ' it is not an elementary model'
  833. call erreur(19)
  834. return
  835. endif
  836. imodel=kmodel(1)
  837. iob=ivamod(/1)
  838. do io=iob,1,-1
  839. ctyp=tymode(io)
  840. if( ctyp.eq.'ENTIER') then
  841. call ecrent(ivamod(io))
  842. else
  843. ipoin1=ivamod(io)
  844. call ecrobj(ctyp,ipoin1)
  845. endif
  846. enddo
  847. return
  848.  
  849. ELSEIF (CMOT.EQ.'ZONE') THEN
  850. M=NSOUS*2
  851. N1 = 1
  852. SEGINI MTABLE
  853. IF(NSOUS.NE.0) THEN
  854. DO 128 IOK=1,NSOUS
  855. IMODEL=KMODEL(IOK)
  856. NFOR=FORMOD(/2)
  857. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  858. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  859. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  860. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  861. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  862. SEGINI,IMODE1= IMODEL
  863. IMODE1.INFMOD(2)=0
  864. IMODEL=IMODE1
  865. ENDIF
  866. SEGINI MMODE1
  867. MMODE1.KMODEL(1) = IMODEL
  868. IPP1= MMODE1
  869. IPP2=IMAMOD
  870. IVALI1=IOK*2 -1
  871. IVALI2=IOK*2
  872. CALL ECCTAB(MTABLE,'ENTIER ',IVALI1,XFLOT,MOT_8,LAG,
  873. $ IOBIN,'MMODEL ',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  874. CALL ECCTAB(MTABLE,'ENTIER ',IVALI2,XFLOT,MOT_8,LAG,
  875. $ IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP2)
  876. 128 CONTINUE
  877. ENDIF
  878. CALL ECROBJ('TABLE ',MTABLE)
  879. RETURN
  880.  
  881. ELSEIF (CMOT.EQ.'FORM'.OR.CMOT.EQ.'CONS'.OR.CMOT.EQ.'ELEM'.OR.
  882. $ CMOT.EQ.'MATE'.OR.CMOT.EQ.'NON_') THEN
  883. INFOR=1
  884. IF (CMOT.EQ.'MATE') THEN
  885. IPASS=0
  886. ICOND=0
  887. 1191 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  888. IF (IERR.NE.0) RETURN
  889. IPASS=IPASS+1
  890. IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN
  891. CALL NOVARD(MMODEL,CMOT)
  892. RETURN
  893. ENDIF
  894. IF (IRETO.NE.0) THEN
  895. INFOR=INFOR+1
  896. IF (INFOR.GT.NBFORM) THEN
  897. CALL ERREUR(5)
  898. RETURN
  899. ENDIF
  900. GOTO 1191
  901. ENDIF
  902. ELSE
  903. ICOND=1
  904. 1192 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  905. IF (IERR.NE.0) RETURN
  906. ICOND=0
  907. IF (IRETO.NE.0) THEN
  908. INFOR=INFOR+1
  909. IF (INFOR.GT.NBFORM) THEN
  910. CALL ERREUR(5)
  911. RETURN
  912. ENDIF
  913. GOTO 1192
  914. ENDIF
  915. ENDIF
  916. INFOR=INFOR-1
  917. C
  918. JGN=4
  919. JGM=0
  920. SEGINI MLMOTS
  921. MLNONL=MLMOTS
  922. C
  923. MMODE1=MMODEL
  924.  
  925. IF (NSOUS .EQ. 0) THEN
  926. C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  927. C partie
  928. CALL ECROBJ('MMODEL ',IPMODL)
  929. RETURN
  930.  
  931. ELSE
  932. N1=NSOUS
  933. SEGINI,MMODEL
  934. IPP1=MMODEL
  935. NZON=0
  936. IMECAF=0
  937. DO 1119 I=1,NSOUS
  938. IMODEL=MMODE1.KMODEL(I)
  939. IF(CMOT.EQ.'FORM') THEN
  940. NFOR=FORMOD(/2)
  941.  
  942. IF(NFOR.NE.INFOR) GOTO 1119
  943. IF(NFOR.EQ.1) THEN
  944. IF(MOFORM(1).NE.FORMOD(1)) GOTO 1119
  945. ELSEIF(NFOR.EQ.2) THEN
  946. IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE.
  947. $ FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND.
  948. $ (MOFORM(2).NE.FORMOD(1))))GOTO 1119
  949. ELSE
  950. GOTO 1118
  951. ENDIF
  952. ELSEIF (CMOT.EQ.'CONS') THEN
  953. DO 425 IJ=1,INFOR
  954. C on enleve les espaces au debut et a la fin
  955. idim0=LEN(MOFORM(IJ))
  956. idim1=CONMOD(/1)
  957. ideb0=0
  958. ifin0=0
  959. ideb1=0
  960. ifin1=0
  961. DO ii=1,idim0
  962. IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ')
  963. $ ideb0=ii
  964. IF(ifin0.EQ.0.AND.
  965. & MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ')
  966. & ifin0=idim0-ii+1
  967. ENDDO
  968. DO ii=1,idim1
  969. IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii
  970. IF(ifin1.EQ.0.AND.
  971. & CONMOD(idim1-ii+1:idim1-ii+1).NE.' ')
  972. & ifin1=idim1-ii+1
  973. ENDDO
  974. C print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1
  975. IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1))
  976. & GOTO 429
  977. 425 CONTINUE
  978. GOTO 1119
  979. ELSEIF (CMOT.EQ.'ELEM') THEN
  980. DO 426 IJ=1,INFOR
  981. IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GOTO 429
  982. 426 CONTINUE
  983. GOTO 1119
  984. ELSEIF(CMOT.EQ.'MATE') THEN
  985. NMAT=MATMOD(/2)
  986. DO 427 IJ=1,INFOR
  987. DO 4275 JJ=1,NMAT
  988. IF(MATMOD(JJ).EQ.MOFORM(IJ)) GOTO 429
  989. 4275 CONTINUE
  990. 427 CONTINUE
  991. GOTO 1119
  992. ELSEIF(CMOT.EQ.'NON_') THEN
  993. MN3=INFMOD(/1)
  994. IF(MN3.LE.12) GOTO 1119
  995. INLOC=-1*INFMOD(13)
  996. IF(INLOC.EQ.0) GOTO 1119
  997. CALL MODNLO(MNLOCA,NLODIM)
  998. DO 428 IJ=1,INFOR
  999. IF(MNLOCA(INLOC).EQ.MOFORM(IJ)(1:4)) GOTO 429
  1000. 428 CONTINUE
  1001. GOTO 1119
  1002. ENDIF
  1003. C on vient ici pour prendre les sous modeles
  1004. 429 CONTINUE
  1005. NZON=NZON+1
  1006. NFOR=FORMOD(/2)
  1007.  
  1008. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  1009. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  1010. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  1011. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  1012. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  1013. IMECAF=1
  1014. SEGINI,IMODE1=IMODEL
  1015. IMODE1.INFMOD(2)=0
  1016. IMODEL=IMODE1
  1017. ENDIF
  1018.  
  1019. KMODEL(NZON)=IMODEL
  1020. 1119 CONTINUE
  1021. ENDIF
  1022. C
  1023. IF(NZON.EQ.0) GOTO 1118
  1024.  
  1025. IF(NZON.EQ.NSOUS .AND. IMECAF.EQ.0) THEN
  1026. C Le SOUS-MODELE demande est le MODELE d'origine
  1027. CALL ECROBJ('MMODEL ',IPMODL)
  1028.  
  1029. ELSE
  1030. IF(NZON.NE.NSOUS)THEN
  1031. N1=NZON
  1032. SEGADJ,MMODEL
  1033. ENDIF
  1034. CALL ACTOBJ('MMODEL ',IPP1,1)
  1035. CALL ECROBJ('MMODEL ',IPP1)
  1036. ENDIF
  1037. RETURN
  1038.  
  1039. 1118 CONTINUE
  1040. CALL ERREUR(610)
  1041. RETURN
  1042.  
  1043. ELSEIF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN
  1044. CALL NOVARD(MMODEL,CMOT)
  1045. RETURN
  1046.  
  1047. ELSEIF (IRET.EQ.22) THEN
  1048. JGN=4
  1049. JGM=0
  1050. SEGINI MLMOTS
  1051. MLNONL=MLMOTS
  1052. C
  1053. MMODE1=MMODEL
  1054. NSOUS=MMODE1.KMODEL(/1)
  1055. C
  1056. C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  1057. C partie
  1058. IF (NSOUS .EQ. 0) THEN
  1059. SEGACT,MLMOTS
  1060. CALL ECROBJ('LISTMOTS',MLMOTS)
  1061. RETURN
  1062. ELSE
  1063. DO 1122 I=1,NSOUS
  1064. IMODEL=MMODE1.KMODEL(I)
  1065. NFOR=FORMOD(/2)
  1066. IF(NFOR.GE.1) THEN
  1067. IF (FORMOD(1).NE.'MECANIQUE'.AND.
  1068. & FORMOD(1).NE.'POREUX') GOTO 1123
  1069. MN3=INFMOD(/1)
  1070. IF(MN3.LE.12) GOTO 1123
  1071. INONL=INFMOD(14)
  1072. IF(INONL.EQ.0) GOTO 1123
  1073. MLMOT1=INONL
  1074. SEGACT MLMOT1
  1075. NMONL=MLMOT1.MOTS(/2)
  1076. IF(NMONL.EQ.0)THEN
  1077. SEGDES MLMOT1
  1078. GOTO 1123
  1079. ENDIF
  1080. IF(JGM.EQ.0) THEN
  1081. JGM=NMONL
  1082. SEGADJ,MLMOTS
  1083. DO IJ=1,NMONL
  1084. MOTS(IJ)=MLMOT1.MOTS(IJ)
  1085. ENDDO
  1086. ELSE
  1087. DO IJ=1,NMONL
  1088. CALL PLACE(MOTS,JGM,IPLA,MLMOT1.MOTS(IJ))
  1089. IF(IPLA.EQ.0) THEN
  1090. JGM=JGM+1
  1091. SEGADJ,MLMOTS
  1092. MOTS(JGM)=MLMOT1.MOTS(IPLA)
  1093. ENDIF
  1094. ENDDO
  1095. ENDIF
  1096. SEGDES MLMOT1
  1097. 1123 CONTINUE
  1098. ENDIF
  1099. 1122 CONTINUE
  1100. SEGACT,MLMOTS
  1101. CALL ECROBJ('LISTMOTS',MLMOTS)
  1102. RETURN
  1103. ENDIF
  1104. ELSE
  1105. MOTERR(1:4)=CMOT
  1106. CALL ERREUR(7)
  1107. RETURN
  1108. ENDIF
  1109.  
  1110.  
  1111. * +-------------------------------------------------------------------+
  1112. * | |
  1113. * | C H A R G E M E N T |
  1114. * | |
  1115. * +-------------------------------------------------------------------+
  1116. ELSEIF (CTYP.EQ.'CHARGEME') THEN
  1117. CALL LIROBJ('CHARGEME',ICHAR,1,IRET)
  1118. IF (IERR.NE.0) RETURN
  1119. C
  1120. CMOT = ' '
  1121. ICHGT = 0
  1122. LCHGT = 0
  1123. IEC = 1
  1124. CALL LIROBJ('LISTMOTS',LCHGT,0,IRET)
  1125. IF (IERR.NE.0) RETURN
  1126. IF (IRET.EQ.0) THEN
  1127. CALL LIRCHA(CMOT,1,IRETOU)
  1128. IF (IERR.NE.0) RETURN
  1129. CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT)
  1130. IF (ICHGT.GE.1 .AND. ICHGT.LE.5) THEN
  1131. CALL LIRENT(IEC,0,IRETOU)
  1132. IF (IERR.NE.0) RETURN
  1133. IF (IRETOU.EQ.0) IEC = 1
  1134. ELSEIF (ICHGT.EQ.0) THEN
  1135. CALL LIRCHA(MOT_4,0,IRETOU)
  1136. IF (IRETOU.NE.0) THEN
  1137. IF (MOT_4.EQ.'TABL') THEN
  1138. ICHGT=-1
  1139. ELSE
  1140. CALL REFUS
  1141. ENDIF
  1142. ENDIF
  1143. ENDIF
  1144. ENDIF
  1145. C
  1146. CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8)
  1147. C
  1148. IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1)
  1149. IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2)
  1150. RETURN
  1151.  
  1152.  
  1153. * +-------------------------------------------------------------------+
  1154. * | |
  1155. * | L I S T C H P O |
  1156. * | |
  1157. * +-------------------------------------------------------------------+
  1158. ELSEIF (CTYP.EQ.'LISTCHPO') THEN
  1159. CALL LIROBJ('LISTCHPO',ILCHP1,1,IRET)
  1160. IF (IERR.NE.0) RETURN
  1161. CALL QUETYP(CTYP1,0,IRETOU)
  1162. IF (IRETOU.EQ.0) THEN
  1163. CALL ERREUR(533)
  1164. RETURN
  1165. ENDIF
  1166.  
  1167. MLCHP1 = ILCHP1
  1168. SEGACT , MLCHP1
  1169. LONCHP = MLCHP1.ICHPOI(/1)
  1170.  
  1171. * ===============================
  1172. * EXTRACTION DE PLUSIEURS INDICES
  1173. * ===============================
  1174. IF (CTYP1.EQ.'LISTENTI') THEN
  1175. CALL LIROBJ('LISTENTI',ILENT,1,IRET)
  1176. IF (IERR.NE.0) GOTO 1212
  1177. MLENTI = ILENT
  1178. SEGACT,MLENTI
  1179. JG = LECT(/1)
  1180. N1=JG
  1181. SEGINI,MLCHP2
  1182. ILCHP2= MLCHP2
  1183. DO 1211 I=1 , JG
  1184. IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN
  1185. INTERR(1) = LECT(I)
  1186. CALL ERREUR(620)
  1187. ENDIF
  1188. MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I))
  1189. 1211 CONTINUE
  1190. SEGDES,MLENTI
  1191. SEGDES,MLCHP1
  1192. SEGDES,MLCHP2
  1193. CALL ECROBJ ('LISTCHPO',ILCHP2)
  1194. RETURN
  1195.  
  1196. * ===========================
  1197. * EXTRACTION D'UN SEUL INDICE
  1198. * ===========================
  1199. ELSEIF (CTYP1.EQ.'ENTIER') THEN
  1200. CALL LIRENT(ILENT,1,IRETOU)
  1201. IF (IERR.NE.0) GOTO 1212
  1202. IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN
  1203. INTERR(1)=ILENT
  1204. CALL ERREUR(620)
  1205. ENDIF
  1206. ILCHPO = MLCHP1.ICHPOI(ILENT)
  1207. SEGDES,MLCHP1
  1208. CALL ECROBJ('CHPOINT ',ILCHPO)
  1209. RETURN
  1210.  
  1211. * ====================================================
  1212. * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN UN POINT
  1213. * ====================================================
  1214. ELSEIF (CTYP1.EQ.'MOT') THEN
  1215. CALL LIRCHA(CMOT,1,IRETOU)
  1216. IF (IERR.NE.0) GOTO 1212
  1217. IF (CMOT.NE.'VALE') THEN
  1218. MOTERR(1:4) = 'VALE'
  1219. CALL ERREUR(396)
  1220. GOTO 1212
  1221. ENDIF
  1222. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  1223. IF (IRETOU.EQ.0) THEN
  1224. CALL LIRCHA(MOT_4,0,IRETOU)
  1225. IF (IRETOU.GT.0) THEN
  1226. JGN=4
  1227. JGM=1
  1228. SEGINI,MLMOTS
  1229. MOTS(1)=MOT_4
  1230. SEGDES,MLMOTS
  1231. ENDIF
  1232. ENDIF
  1233. CALL LIROBJ('POINT',MPOINT,1,IRETOU)
  1234. IF (IERR.NE.0) GOTO 1212
  1235. CALL EXTR24(MLCHP1,MLMOTS,MPOINT,MLREEL)
  1236. IF (IERR.NE.0) RETURN
  1237. SEGDES,MLCHP1
  1238. SEGDES,MLREEL
  1239. CALL ECROBJ('LISTREEL',MLREEL)
  1240. RETURN
  1241.  
  1242. * SYNTAXE INCORRECTE
  1243. ELSE
  1244. MOTERR(1:40) = 'ENTIER LISTENTI"VALE"'
  1245. CALL ERREUR(471)
  1246. GOTO 1212
  1247. ENDIF
  1248. C
  1249. C (erreur lors du traitement du LISTCHPO)
  1250. C
  1251. 1212 SEGDES,MLCHP1
  1252. RETURN
  1253.  
  1254.  
  1255. * +-------------------------------------------------------------------+
  1256. * | |
  1257. * | N U A G E |
  1258. * | |
  1259. * +-------------------------------------------------------------------+
  1260. ELSEIF (CTYP.EQ.'NUAGE') THEN
  1261. CALL LIROBJ('NUAGE ',IPOINT,1,IRET)
  1262. IF (IERR.NE.0) RETURN
  1263.  
  1264. MNUAGE=IPOINT
  1265. SEGACT MNUAGE
  1266. CALL LIRMOT(NUMO,5,INU1,0)
  1267. IF (INU1.EQ.0) THEN
  1268. CALL LIRCHA(CTYP1,1,IRETOU)
  1269. IF (IERR.NE.0) THEN
  1270. C SEGDES MNUAGE
  1271. RETURN
  1272. ENDIF
  1273. CALL LIRMOT(NUMO,5,INU1,0)
  1274. IF (INU1.EQ.0) THEN
  1275. IF (CTYP1.EQ.'COMP ') THEN
  1276. IPROG = 1
  1277. ELSE
  1278. IPOSI = 0
  1279. DO 1250 I=1,NUANOM(/2)
  1280. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1281. 1250 CONTINUE
  1282. IF (IPOSI.EQ.0) THEN
  1283. C SEGDES MNUAGE
  1284. MOTERR(1:8) = CTYP1
  1285. C TYP1 n'est pas un nom de variable du NUAGE
  1286. CALL ERREUR(672)
  1287. RETURN
  1288. ENDIF
  1289. IPROG = 2
  1290. ENDIF
  1291. ELSE
  1292. IPOSI = 0
  1293. DO 1251 I=1,NUANOM(/2)
  1294. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1295. 1251 CONTINUE
  1296. IF (IPOSI.EQ.0) THEN
  1297. C SEGDES MNUAGE
  1298. MOTERR(1:8) = CTYP1
  1299. C TYP1 n'est pas un nom de variable du NUAGE
  1300. CALL ERREUR(672)
  1301. RETURN
  1302. ENDIF
  1303. IPROG = 3
  1304. ENDIF
  1305. ELSE
  1306. CALL LIRCHA(CTYP1,1,IRETOU)
  1307. IF (IERR.NE.0) THEN
  1308. C SEGDES MNUAGE
  1309. RETURN
  1310. ENDIF
  1311. IPOSI = 0
  1312. DO 1252 I=1,NUANOM(/2)
  1313. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1314. 1252 CONTINUE
  1315. IF (IPOSI.EQ.0) THEN
  1316. C SEGDES,MNUAGE
  1317. MOTERR(1:8) = CTYP1
  1318. C TYP1 n'est pas un nom de variable du NUAGE
  1319. CALL ERREUR(672)
  1320. RETURN
  1321. ELSE
  1322. IPROG = 3
  1323. ENDIF
  1324. ENDIF
  1325.  
  1326. C-------------- Lecture eventuelle des FLOTTANTS -------------
  1327. IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN
  1328. IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN
  1329. CALL LIRREE(XVAL1,0,IRETOU)
  1330. IF (IRETOU.EQ.0) THEN
  1331. C SEGDES,MNUAGE
  1332. C Il manque la valeur de la composante reelle
  1333. CALL ERREUR(668)
  1334. RETURN
  1335. ENDIF
  1336. ELSE
  1337. CALL LIRREE(XVAL1,0,IRETO1)
  1338. CALL LIRREE(XVAL2,0,IRETO2)
  1339. IF ((IRETO1.EQ.0).OR.(IRETO2.EQ.0)) THEN
  1340. C SEGDES,MNUAGE
  1341. C Il faut specifier deux valeurs reelles
  1342. CALL ERREUR(673)
  1343. RETURN
  1344. ENDIF
  1345. ENDIF
  1346. ENDIF
  1347. C SEGDES MNUAGE
  1348.  
  1349. C--------- Cas de l'extraction des noms des composantes du NUAGE -------
  1350. IF (IPROG.EQ.1) THEN
  1351. CALL EXTR19(IPOINT,IPLSTM)
  1352. IF (IPLSTM.NE.0) THEN
  1353. CALL ECROBJ('LISTMOTS',IPLSTM)
  1354. ENDIF
  1355.  
  1356. C----Cas de l'extraction de l'objet correspondant a une composante ---
  1357. C----------------- donnee d'un NUAGE "colonne" -----------------------
  1358.  
  1359. ELSEIF (IPROG.EQ.2) THEN
  1360. CALL EXTR51(IPOINT,IPOSI)
  1361.  
  1362. C---------------------------- Autres cas ------------------------------
  1363. ELSEIF (IPROG.EQ.3) THEN
  1364. IF (INU1.EQ.1) THEN
  1365. BORINF=.TRUE.
  1366. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1367. ELSEIF (INU1.EQ.2) THEN
  1368. BORINF=.FALSE.
  1369. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1370. ELSEIF (INU1.EQ.3) THEN
  1371. MINI =.TRUE.
  1372. CALL EXTR52(IPOINT,MINI,IPOSI)
  1373. ELSEIF (INU1.EQ.4) THEN
  1374. MINI =.FALSE.
  1375. CALL EXTR52(IPOINT,MINI,IPOSI)
  1376. ELSEIF (INU1.EQ.5) THEN
  1377. CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
  1378. ELSE
  1379. CALL ERREUR(21)
  1380. RETURN
  1381. ENDIF
  1382.  
  1383. C---------------------------- Cas non prevus ---------------------------
  1384. ELSE
  1385. CALL ERREUR(21)
  1386. RETURN
  1387. ENDIF
  1388. RETURN
  1389.  
  1390. ENDIF
  1391.  
  1392.  
  1393. ***********************************************************************
  1394. * ON TRAITE LES LISTENTI, LISTREEL ET LISTMOTS SEPAREMENT POUR *
  1395. * POUVOIR TOLERER L'INVERSION DES DEUX ARGUMENTS (LA LISTE PRINCIPALE *
  1396. * ET L'INDICE/LA LISTE D'INDICES) *
  1397. ***********************************************************************
  1398.  
  1399.  
  1400. * +-------------------------------------------------------------------+
  1401. * | |
  1402. * | L I S T M O T S |
  1403. * | |
  1404. * +-------------------------------------------------------------------+
  1405. 10 CONTINUE
  1406. CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET)
  1407. IF (IRET.EQ.0) GOTO 20
  1408.  
  1409. MLMOT1 = ILMOT1
  1410. SEGACT , MLMOT1
  1411. LONMOT = MLMOT1.MOTS(/2)
  1412. JGN = MLMOT1.MOTS(/1)
  1413.  
  1414. * ===============================
  1415. * EXTRACTION DE PLUSIEURS INDICES
  1416. * ===============================
  1417. CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1418. IF ( IRET .EQ. 1 ) THEN
  1419. MLENTI = ILENT
  1420. SEGACT , MLENTI
  1421. JGM = LECT(/1)
  1422. SEGINI , MLMOT2
  1423. ILMOT2= MLMOT2
  1424. DO 1221 I=1 , JGM
  1425. IF (( LECT(I) .GT. LONMOT ) .OR. ( LECT(I) .LT. 1 )) THEN
  1426. INTERR(1) = LECT(I)
  1427. CALL ERREUR(620)
  1428. ENDIF
  1429. MLMOT2.MOTS(I) = MLMOT1.MOTS(LECT(I))
  1430. 1221 CONTINUE
  1431. SEGDES , MLENTI
  1432. SEGDES , MLMOT1
  1433. SEGDES , MLMOT2
  1434. CALL ECROBJ ('LISTMOTS',ILMOT2)
  1435. RETURN
  1436.  
  1437. * ===========================
  1438. * EXTRACTION D'UN SEUL INDICE
  1439. * ===========================
  1440. ELSE
  1441. CALL LIRENT (ILENT,1,IRETOU)
  1442. IF (IERR .NE. 0) THEN
  1443. SEGDES , MLMOT1
  1444. RETURN
  1445. ENDIF
  1446. IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN
  1447. INTERR(1)=ILENT
  1448. CALL ERREUR(620)
  1449. ELSE
  1450. CTEXT = MLMOT1.MOTS(ILENT)
  1451. ENDIF
  1452. SEGDES , MLMOT1
  1453. CALL ECRCHA(CTEXT(1:JGN))
  1454. RETURN
  1455. ENDIF
  1456.  
  1457.  
  1458. * +-------------------------------------------------------------------+
  1459. * | |
  1460. * | L I S T R E E L |
  1461. * | |
  1462. * +-------------------------------------------------------------------+
  1463. 20 CONTINUE
  1464. CALL LIROBJ('LISTREEL',ILREE1,0,IRET)
  1465. IF (IRET.EQ.0) GOTO 30
  1466.  
  1467. MLREE1 = ILREE1
  1468. SEGACT , MLREE1
  1469. LONREE = MLREE1.PROG(/1)
  1470.  
  1471. * ===============================
  1472. * EXTRACTION DE PLUSIEURS INDICES
  1473. * ===============================
  1474. CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1475. IF ( IRET .EQ. 1 ) THEN
  1476. MLENTI = ILENT
  1477. SEGACT , MLENTI
  1478. JG = LECT(/1)
  1479. SEGINI , MLREE2
  1480. ILREE2= MLREE2
  1481. DO 1231 I=1 , JG
  1482. IF (( LECT(I) .GT. LONREE ) .OR. ( LECT(I) .LT. 1 )) THEN
  1483. INTERR(1) = LECT(I)
  1484. CALL ERREUR(620)
  1485. ENDIF
  1486. MLREE2.PROG(I) = MLREE1.PROG(LECT(I))
  1487. 1231 CONTINUE
  1488. SEGDES , MLENTI
  1489. SEGDES , MLREE1
  1490. SEGDES , MLREE2
  1491. CALL ECROBJ ('LISTREEL',ILREE2)
  1492. RETURN
  1493.  
  1494. * ===========================
  1495. * EXTRACTION D'UN SEUL INDICE
  1496. * ===========================
  1497. ELSE
  1498. CALL LIRENT (ILENT,1,IRETOU)
  1499. IF (IERR .NE. 0) THEN
  1500. SEGDES , MLREE1
  1501. RETURN
  1502. ENDIF
  1503. IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN
  1504. INTERR(1)=ILENT
  1505. CALL ERREUR(620)
  1506. ELSE
  1507. REELDP = MLREE1.PROG(ILENT)
  1508. ENDIF
  1509. SEGDES , MLREE1
  1510. CALL ECRREE(REELDP)
  1511. RETURN
  1512. ENDIF
  1513. 124 CONTINUE
  1514.  
  1515.  
  1516. * +-------------------------------------------------------------------+
  1517. * | |
  1518. * | L I S T E N T I |
  1519. * | |
  1520. * +-------------------------------------------------------------------+
  1521. 30 CONTINUE
  1522. CALL LIROBJ('LISTENTI',ILENT1,0,IRET)
  1523. IF (IRET.EQ.0) GOTO 999
  1524.  
  1525. MLENT1 = ILENT1
  1526. SEGACT , MLENT1
  1527. LONENT = MLENT1.LECT(/1)
  1528.  
  1529. * ===============================
  1530. * EXTRACTION DE PLUSIEURS INDICES
  1531. * ===============================
  1532. CALL LIROBJ('LISTENTI',ILENT2,0,IRET)
  1533. IF ( IRET .EQ. 1 ) THEN
  1534. MLENT2 = ILENT2
  1535. SEGACT , MLENT2
  1536. JG = MLENT2.LECT(/1)
  1537. SEGINI , MLENT3
  1538. ILENT3= MLENT3
  1539. DO 1241 I=1 , JG
  1540. IF (MLENT2.LECT(I).GT.LONENT.OR.MLENT2.LECT(I).LT.1) THEN
  1541. INTERR(1) = MLENT2.LECT(I)
  1542. CALL ERREUR(620)
  1543. ENDIF
  1544. MLENT3.LECT(I) = MLENT1.LECT(MLENT2.LECT(I))
  1545. 1241 CONTINUE
  1546. SEGDES , MLENT1
  1547. SEGDES , MLENT2
  1548. SEGDES , MLENT3
  1549. CALL ECROBJ ('LISTENTI',ILENT3)
  1550. RETURN
  1551.  
  1552. * ===========================
  1553. * EXTRACTION D'UN SEUL INDICE
  1554. * ===========================
  1555. ELSE
  1556. CALL LIRENT (ILENT,1,IRETOU)
  1557. IF (IERR .NE. 0) THEN
  1558. SEGDES , MLENT1
  1559. RETURN
  1560. ENDIF
  1561. IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN
  1562. INTERR(1)=ILENT
  1563. CALL ERREUR(620)
  1564. ELSE
  1565. INTEGR = MLENT1.LECT(ILENT)
  1566. ENDIF
  1567. SEGDES , MLENT1
  1568. CALL ECRENT(INTEGR)
  1569. RETURN
  1570. ENDIF
  1571.  
  1572.  
  1573.  
  1574.  
  1575. * +-------------------------------------------------------------------+
  1576. * | 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 |
  1577. * +-------------------------------------------------------------------+
  1578. 999 CONTINUE
  1579. CALL ERREUR(676)
  1580.  
  1581. END
  1582.  
  1583.  
  1584.  
  1585.  
  1586.  

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