Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

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

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