Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTRAI SOURCE MB234859 18/11/21 21:15:03 10006
  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
  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 ECROBJ('CHPOINT ',ICHP)
  357. RETURN
  358.  
  359. * ========================================================
  360. * MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  361. * ========================================================
  362. ELSEIF(IRET.EQ.6) THEN
  363. CALL LIRCHA(CMOT,0,ICDUAL)
  364. IF (ICDUAL.NE.0) THEN
  365. IF (CMOT.NE.'DUAL') THEN
  366. MOTERR(1:4)=CMOT
  367. CALL ERREUR(7)
  368. RETURN
  369. ENDIF
  370. ENDIF
  371. CALL EXTR16(IBOGID,ICDUAL,IPLSTM)
  372. CALL ECROBJ('LISTMOTS',IPLSTM)
  373. RETURN
  374.  
  375. * ====================================
  376. * MOT-CLE "CONT" => APPUIS UNILATERAUX
  377. * ====================================
  378. ELSEIF(IRET.EQ.5) THEN
  379. MRIGID=IBOGID
  380. SEGACT MRIGID
  381. ISOPE= ISUPEQ
  382. IF(ISUPEQ.EQ.0) CALL CRTABL(ISOPE)
  383. MTABLE=ISOPE
  384. SEGDES MTABLE
  385. CALL ECROBJ('TABLE ',ISOPE)
  386. RETURN
  387.  
  388. * ==============================================================
  389. * MOTS-CLES "SYME" OU "ANTI" => SOUS-MATRICES (ANTI-)SYMETRIQUES
  390. * ==============================================================
  391. ELSEIF (IRET.EQ.3 .OR. IRET.EQ.4) THEN
  392. CALL EXTR13(IBOGID,IRET)
  393. RETURN
  394. ENDIF
  395.  
  396.  
  397. * =============================================================
  398. * MOTS-CLES "MAIL" OU "RIGI" => SOUS-MAILLAGES OU SOUS-MATRICES
  399. * =============================================================
  400. ICO=0
  401. IMO=3
  402. IF(IRET.EQ.2) THEN
  403. ICO=1
  404. IMO=2
  405. ENDIF
  406. CALL LIRMOT(NOMU,IMO,IMUL,ICO)
  407. IF(IERR.NE.0) RETURN
  408.  
  409. * ************************************************
  410. * MATRICE AVEC SEULEMENT LES MULT. DE LAGRANGE OU
  411. * AVEC TOUT SAUF LES MULT. DE LAGRANGE
  412. * ************************************************
  413. IF (IRET.EQ.2) THEN
  414. CALL SEPA(IBOGID,IMUL)
  415. CALL ECROBJ('RIGIDITE',IBOGID)
  416. RETURN
  417. ENDIF
  418.  
  419. * ********************************************************
  420. * MAILLAGE PARTIEL
  421. * "NOMU" => TOUT SAUF LES MULT. DE LAGRANGE
  422. * "MULT" => TOUS LES MULT. DE LAGRANGE
  423. * "UNIL" => SEULEMENT LES MULT. ASSOCIES AUX COND. UNIL.
  424. * ********************************************************
  425. IF (IMUL.NE.0) THEN
  426. CALL POIRIG(IBOGID,IMUL)
  427. RETURN
  428. ENDIF
  429.  
  430. * ****************
  431. * MAILLAGE COMPLET
  432. * ****************
  433. IF (IERR.NE.0) RETURN
  434. MRIGID=IBOGID
  435. SEGACT MRIGID
  436. NBSOUS=IRIGEL(/2)
  437. IF (NBSOUS.EQ.0) THEN
  438. NBNN=0
  439. NBELEM=0
  440. NBREF=0
  441. SEGINI MELEME
  442. SEGDES MELEME,MRIGID
  443. CALL ECROBJ ('MAILLAGE',MELEME)
  444. RETURN
  445. ENDIF
  446. IPP1 = IRIGEL(1,1)
  447. IF(NBSOUS.GT.1) THEN
  448. NBREF=0
  449. NBNN=0
  450. NBELEM=0
  451. SEGINI IPT4
  452. KT4 = 1
  453. IPT4.LISOUS(KT4) = IPP1
  454. DO 1130 I=1,NBSOUS
  455. DO 1129 JJ = 1,KT4
  456. IF (IRIGEL(1,I).EQ.IPT4.LISOUS(JJ)) GOTO 1130
  457. 1129 CONTINUE
  458. KT4 = KT4 + 1
  459. IPT4.LISOUS(KT4)=IRIGEL(1,I)
  460. 1130 CONTINUE
  461. NBSOUS = KT4
  462. SEGADJ IPT4
  463. CALL FUSEBO (IPT4,IPP1)
  464. ENDIF
  465. SEGDES MRIGID
  466. CALL ECROBJ('MAILLAGE',IPP1)
  467. RETURN
  468.  
  469.  
  470. * +-------------------------------------------------------------------+
  471. * | |
  472. * | C H P O I N T |
  473. * | |
  474. * +-------------------------------------------------------------------+
  475. ELSE IF (CTYP.EQ.'CHPOINT') THEN
  476. CALL LIROBJ('CHPOINT ',IBOPOI,1,IRETOU)
  477. IF (IERR.NE.0) RETURN
  478. CALL LIRCHA(CMOT,1,IRETOU)
  479. IF (IERR.NE.0) RETURN
  480.  
  481. * =====================================
  482. * MOT-CLE "TITR" => EXTRACTION DU TITRE
  483. * =====================================
  484. IF (CMOT.EQ.'TITR') THEN
  485. MCHPOI = IBOPOI
  486. SEGACT MCHPOI
  487. CTEXT = MOCHDE
  488. SEGDES MCHPOI
  489. ILON = LEN(CTEXT)
  490. DO 100 I = ILON,1,-1
  491. IF (CTEXT(I:I).NE.' ') THEN
  492. NLON = I
  493. GOTO 102
  494. ENDIF
  495. 100 CONTINUE
  496. NLON = 1
  497. 102 CONTINUE
  498. CALL ECRCHA(CTEXT(1:NLON))
  499. RETURN
  500.  
  501. * =========================================
  502. * MOT-CLE "NATU" => EXTRACTION DE LA NATURE
  503. * =========================================
  504. ELSE IF (CMOT.EQ.'NATU') THEN
  505. MCHPOI = IBOPOI
  506. SEGACT MCHPOI
  507. INAT = JATTRI(1)
  508. IF (INAT.EQ.0) CTEXT(1:11) = 'INDETERMINE'
  509. IF (INAT.EQ.1) CTEXT(1:11) = 'DIFFUS '
  510. IF (INAT.EQ.2) CTEXT(1:11) = 'DISCRET '
  511. SEGDES MCHPOI
  512. CALL ECRCHA(CTEXT(1:11))
  513. RETURN
  514.  
  515. * ===================================================
  516. * MOT-CLE "MAIL" => EXTRACTION DU SUPPORT GEOMETRIQUE
  517. * ===================================================
  518. ELSE IF (CMOT .EQ.'MAIL') THEN
  519. IMUL=0
  520. CALL LIRMOT(NOMU,1,IMUL,0)
  521. MCHPOI=IBOPOI
  522. SEGACT MCHPOI
  523. NBSOUS=IPCHP(/1)
  524. IPP1=0
  525. DO 1140 I=1,NBSOUS
  526. MSOUPO=IPCHP(I)
  527. SEGACT MSOUPO
  528. IF(NOCOMP(1).EQ.'LX '.AND.IMUL.EQ.1) GO TO 1140
  529. IF (IPP1.EQ.0) THEN
  530. IPP1= IGEOC
  531. ELSE
  532. IPP2=IGEOC
  533. ltelq=.false.
  534. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  535. IPP1=IRET
  536. ENDIF
  537. SEGDES MSOUPO
  538. 1140 CONTINUE
  539. SEGDES MCHPOI
  540. IF(IPP1.EQ.0) THEN
  541. C Creation Maillage vide
  542. NBELEM=0
  543. NBNN=0
  544. NBREF=0
  545. NBSOUS=0
  546. SEGINI MELEME
  547. ITYPEL = 1
  548. IPP1 = MELEME
  549. C CALL ECRENT( 0)
  550. C ELSE
  551. ENDIF
  552. CALL ECROBJ('MAILLAGE',IPP1)
  553. RETURN
  554.  
  555. * ========================================================
  556. * MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  557. * ========================================================
  558. ELSE IF (CMOT .EQ.'COMP') THEN
  559. CALL EXTR11(IBOPOI,KLISTM)
  560. CALL ECROBJ('LISTMOTS',KLISTM)
  561. RETURN
  562.  
  563. * ====================================
  564. * MOT-CLE "TYPE" => EXTRACTION DU TYPE
  565. * ====================================
  566. ELSE IF (CMOT.EQ.'TYPE') THEN
  567. MCHPOI = IBOPOI
  568. SEGACT MCHPOI
  569. MOT_8 = MTYPOI
  570. SEGDES MCHPOI
  571. CALL ECRCHA(MOT_8(1:8))
  572. RETURN
  573.  
  574. * ============================================================
  575. * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN PLUSIEURS POINTS
  576. * ET POUR PLUSIEURS COMPOSANTES
  577. * ============================================================
  578. ELSE IF (CMOT.EQ.'VALE') THEN
  579. *
  580. * LISTE DES COMPOSANTES (OBJET MOT OU LISTMOTS)
  581. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  582. IF (IRETOU.EQ.0) THEN
  583. CALL LIRCHA(MOT_4,0,IRETOU)
  584. IF (IRETOU.GT.0) THEN
  585. JGN=4
  586. JGM=1
  587. SEGINI,MLMOTS
  588. MOTS(1)=MOT_4
  589. SEGDES,MLMOTS
  590. ENDIF
  591. ENDIF
  592. *
  593. * LISTE DES NOEUDS (OBJET POINT OU MAILLAGE DE POI1)
  594. CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  595. IF (IRETOU.EQ.0) THEN
  596. CALL LIROBJ('POINT',IPOINT,0,IRETOU)
  597. IF (IRETOU.NE.0) THEN
  598. CALL CRELEM(IPOINT)
  599. MELEME=IPOINT
  600. ENDIF
  601. ENDIF
  602. *
  603. * MOT-CLE 'NOID'
  604. IVID=0
  605. CALL LIRCHA(MOT_4,0,IRETOU)
  606. IF (IRETOU.NE.0) THEN
  607. IF (MOT_4.EQ.'NOID') THEN
  608. IVID=1
  609. ELSE
  610. MOTERR(1:4)=MOT_4
  611. MOTERR(5:40)='NOID'
  612. CALL ERREUR(1052)
  613. RETURN
  614. ENDIF
  615. ENDIF
  616. *
  617. * APPEL A EXTR23
  618. CALL EXTR23(IBOPOI,MLMOTS,MELEME,MLREEL,IVID)
  619. IF (IERR.NE.0) RETURN
  620. CALL ECROBJ('LISTREEL',MLREEL)
  621. RETURN
  622.  
  623. * ===========================================================
  624. * EXTRACTION DE LA VALEUR EN UN POINT D'UNE COMPOSANTE DONNEE
  625. * ===========================================================
  626. ELSE
  627. CALL LIROBJ('POINT ',MPOINT,1,IRETOU)
  628. IF (IRETOU.EQ.0) THEN
  629. MOTERR(1:8)='POINT'
  630. CALL ERREUR(37)
  631. RETURN
  632. ENDIF
  633. CALL EXTRA9(IBOPOI,MPOINT,CMOT,KERRE,XFLOT)
  634. IF (KERRE.EQ.0) THEN
  635. CALL ECRREE(XFLOT)
  636. RETURN
  637. ENDIF
  638. MOTERR(1:4)=CMOT
  639. MOTERR(5:12)='CHPOINT'
  640. INTERR(1)=MPOINT
  641. CALL ERREUR(65)
  642. RETURN
  643. ENDIF
  644.  
  645.  
  646.  
  647. * +-------------------------------------------------------------------+
  648. * | |
  649. * | M C H A M L |
  650. * | |
  651. * +-------------------------------------------------------------------+
  652. ELSE IF (CTYP.EQ.'MCHAML') THEN
  653. CALL LIROBJ('MCHAML',IPCHE1,1,IRET)
  654. IF (IERR.NE.0) RETURN
  655. C
  656. CALL LIRCHA(CMOT,1,IRET0)
  657. IF (IERR.NE.0) RETURN
  658.  
  659.  
  660. * ================================================
  661. * MOTS-CLES "DEVA" OU "COVA" => NOMS DES VARIABLES
  662. * ================================================
  663. IF (CMOT.EQ.'DEVA'.OR.CMOT.EQ.'COVA') THEN
  664. CALL EXCHA1(IPCHE1,ILISR,CMOT)
  665. IF (ILISR.NE.0) CALL ECROBJ('LISTMOTS',ILISR)
  666. RETURN
  667.  
  668. * =================================
  669. * MOT-CLE "NBZO" => NOMBRE DE ZONES
  670. * =================================
  671. ELSE IF (CMOT.EQ.'NBZO') THEN
  672. CALL EXTR18(IPCHE1,NBZONE)
  673. if (ierr.ne.0) return
  674. CALL ECRENT(NBZONE)
  675. RETURN
  676.  
  677. * =====================================================
  678. * MOT-CLE "COMP" => EXTRACTION DES NOMS DES COMPOSANTES
  679. * =====================================================
  680. ELSE IF (CMOT.EQ.'COMP' ) THEN
  681. CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  682. C
  683. C RECHERCHE DES NOMS DES COMPOSANTES APPARTENANT
  684. C A LA ZONE DU MODELE
  685. IF (IRETM.NE.0) THEN
  686. CALL EXTR15(IPMODL,IPCHE1,IPLSTM)
  687. IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  688. RETURN
  689. C
  690. C RECHERCHE DES NOMS DE TOUTES LES COMPOSANTES
  691. ELSE
  692. CALL EXTR17(IPCHE1,IPLSTM)
  693. CALL ECROBJ('LISTMOTS',IPLSTM)
  694. RETURN
  695. ENDIF
  696.  
  697. * ======================================================
  698. * MOT-CLE "CONS" => EXTRACTION DES NOMS DES CONSTITUANTS
  699. * ======================================================
  700. ELSE IF(CMOT.EQ.'CONS' ) THEN
  701. CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  702. C
  703. C RECHERCHE DES NOMS DES CONSTITUANTS APPARTENANT
  704. C A LA ZONE DU MODELE
  705. IF (IRETM.NE.0) THEN
  706. CALL EXTR35(IPMODL,IPCHE1,IPLSTM)
  707. IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  708. RETURN
  709. C
  710. C RECHERCHE DES NOMS DE TOUs LES constituants
  711. ELSE
  712. CALL EXTR37(IPCHE1,IPLSTM)
  713. CALL ECROBJ('LISTMOTS',IPLSTM)
  714. RETURN
  715. ENDIF
  716.  
  717. * =========================================================
  718. * EXTRACTION DE LA VALEUR, DU TITRE, DU TYPE OU DU MAILLAGE
  719. * =========================================================
  720. ELSE
  721. IF (CMOT.NE.'TITR'.AND.CMOT.NE.'TYPE'.AND.CMOT.NE.'MAIL')
  722. $ THEN
  723. CALL LIRENT(IENT1,1,IRET1)
  724. IF(IRET1.EQ.0) RETURN
  725. CALL LIRENT(IENT2,1,IRET2)
  726. IF(IRET2.EQ.0) RETURN
  727. CALL LIRENT(IENT3,1,IRET3)
  728. IF(IRET3.EQ.0) RETURN
  729. ENDIF
  730. CALL EXTR14(IPCHE1,IENT1,IENT2,IENT3,CMOT)
  731. RETURN
  732. ENDIF
  733.  
  734.  
  735. * +-------------------------------------------------------------------+
  736. * | |
  737. * | M M O D E L |
  738. * | |
  739. * +-------------------------------------------------------------------+
  740. ELSE IF (CTYP.EQ.'MMODEL') THEN
  741. CALL LIROBJ('MMODEL',IPMODL,1,IRET)
  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. SEGACT MMODEL
  748. NSOUS=KMODEL(/1)
  749. C en cas de modele melange derouler : creer un nouveau mmode
  750. segini limode
  751. do im = 1,NSOUS
  752. imodel = kmodel(im)
  753. segact imodel
  754. limode(**) = imodel
  755. if (formod(1).eq.'MELANGE') then
  756. if (ivamod(/1).ge.1) then
  757. do ivm1 = 1,ivamod(/1)
  758. if (tymode(ivm1).eq.'IMODEL') then
  759. limode(**) = ivamod(ivm1)
  760. endif
  761. enddo
  762. endif
  763. endif
  764. enddo
  765. C segdes mmodel
  766. C test non redondance
  767. N1 = 1
  768. if (limode(/1).gt.1) then
  769. do 1161 it1 = limode(/1),2,-1
  770. imode1 = limode(it1)
  771. segact imode1
  772. do it2 = (it1 - 1) ,1,-1
  773. imode2 = limode(it2)
  774. segact imode2
  775. if (imode1.imamod.eq.imode2.imamod.and.
  776. & imode1.conmod.eq.imode2.conmod) then
  777. limode(it1) = 0
  778. goto 1161
  779. endif
  780. enddo
  781. N1 = N1 + 1
  782. 1161 continue
  783. endif
  784. is1 = 0
  785. if (limode(/1).gt.0) then
  786. segini,mmodel
  787. do is = 1,limode(/1)
  788. if (limode(is).gt.0) then
  789. is1 = is1 + 1
  790. kmodel(is1) = limode(is)
  791. endif
  792. enddo
  793. else
  794. endif
  795. NSOUS=KMODEL(/1)
  796. IPMODL = MMODEL
  797.  
  798. IF (CMOT.EQ.'MAIL') THEN
  799. IMFRO=.FALSE.
  800. CALL LIRMOT(CFROT,1,IRET,0)
  801. IF (IRET.EQ.1) THEN
  802. IMFRO=.TRUE.
  803. ENDIF
  804. MMODEL=IPMODL
  805. SEGACT MMODEL
  806. NSOUS=KMODEL(/1)
  807. IF (KMODEL(/1) .GT. 0) THEN
  808. C Cas du MODELE non VIDE
  809. IMODEL=KMODEL(1)
  810. SEGACT IMODEL
  811. IF (IMFRO) THEN
  812. NMATT=MATMOD(/2)
  813. CALL PLACE(MATMOD,NMATT,IPLAC,'FROTTANT')
  814. IF (IPLAC.EQ.0) THEN
  815. CALL ERREUR(26)
  816. RETURN
  817. ENDIF
  818. IPP1=IVAMOD(1)
  819. ELSE
  820. IPP1=IMAMOD
  821. ENDIF
  822. C SEGDES IMODEL
  823. IF(NSOUS .GT. 1) THEN
  824. DO 1116 I=2,NSOUS
  825. IMODEL=KMODEL(I)
  826. SEGACT IMODEL
  827. IPP2 = IMAMOD
  828. C SEGDES IMODEL
  829. ltelq=.false.
  830. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  831. IPP1=IRET
  832. 1116 CONTINUE
  833. ENDIF
  834. ELSE
  835. C Cas du MODELE VIDE ==> MAILLAGE VIDE
  836. NBELEM=0
  837. NBNN =NBNNE(ILCOUR)
  838. NBREF =0
  839. NBSOUS=0
  840. SEGINI MELEME
  841. ITYPEL = ILCOUR
  842. IPP1 = MELEME
  843. SEGDES,MELEME
  844. ENDIF
  845. C SEGDES MMODEL
  846. CALL ECROBJ('MAILLAGE',IPP1)
  847. RETURN
  848.  
  849. ELSEIF (CMOT.eq.'COMP') THEN
  850. CALL LIRCHA(MOFORM(1),1,iretou)
  851. if(ierr.ne.0) return
  852. MMODEL=IPMODL
  853. SEGACT MMODEL
  854. NSOUS=KMODEL(/1)
  855. segini,MMODE1=MMODEL
  856. N1=0
  857. DO 5497 I=1,NSOUS
  858. IMODEL=KMODEL(I)
  859. SEGACT IMODEL
  860. DO IB=1,MATMOD(/2)
  861. IF( MATMOD(IB).EQ.MOFORM(1)) go to 5498
  862. ENDDO
  863. C SEGDES IMODEL
  864. GO TO 5497
  865. 5498 CONTINUE
  866. N1=N1+1
  867. MMODE1.KMODEL(N1)=KMODEL(I)
  868. C SEGDES IMODEL
  869. 5497 CONTINUE
  870. C SEGDES MMODEL
  871. IF(N1.EQ.0)CALL ERREUR(610)
  872. IF(N1.GE.0.AND.N1.NE.NSOUS) SEGADJ MMODE1
  873. segdes MMODE1
  874. CALL ECROBJ('MMODEL',MMODE1)
  875. RETURN
  876.  
  877. ELSEIF(CMOT.EQ.'OBJE') THEN
  878. mmodel=ipmodl
  879. segact mmodel
  880. if(kmodel(/1).ne.1) then
  881. WRITE(IOIMP,*) ' Dans extrai.eso : '
  882. WRITE(IOIMP,*) ' ce n est pas un modele elementaire'
  883. WRITE(IOIMP,*) ' it is not an elementary model'
  884. call erreur(19)
  885. return
  886. endif
  887. imodel=kmodel(1)
  888. segact imodel
  889. iob=ivamod(/1)
  890. do io=iob,1,-1
  891. ctyp=tymode(io)
  892. if( ctyp.eq.'ENTIER') then
  893. call ecrent(ivamod(io))
  894. else
  895. ipoin1=ivamod(io)
  896. call ecrobj(ctyp,ipoin1)
  897. endif
  898. enddo
  899. C segdes imodel,mmodel
  900. return
  901.  
  902. ELSEIF (CMOT.EQ.'ZONE') THEN
  903. MMODEL=IPMODL
  904. SEGACT MMODEL
  905. NSOUS=KMODEL(/1)
  906. M=NSOUS*2
  907. N1 = 1
  908. SEGINI MTABLE
  909. IF(NSOUS.NE.0) THEN
  910. DO 128 IOK=1,NSOUS
  911. IMODEL=KMODEL(IOK)
  912. SEGACT IMODEL
  913. NFOR=FORMOD(/2)
  914. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  915. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  916. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  917. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  918. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  919. SEGINI,IMODE1= IMODEL
  920. IMODE1.INFMOD(2)=0
  921. C SEGDES IMODEL
  922. IMODEL=IMODE1
  923. ENDIF
  924. SEGINI MMODE1
  925. MMODE1.KMODEL(1) = IMODEL
  926. SEGDES MMODE1
  927. IPP1= MMODE1
  928. IPP2=IMAMOD
  929. IVALI1=IOK*2 -1
  930. IVALI2=IOK*2
  931. CALL ECCTAB(MTABLE,'ENTIER ',IVALI1,XFLOT,MOT_8,LAG,
  932. $ IOBIN,'MMODEL ',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  933. CALL ECCTAB(MTABLE,'ENTIER ',IVALI2,XFLOT,MOT_8,LAG,
  934. $ IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP2)
  935. C SEGDES IMODEL
  936. 128 CONTINUE
  937. ENDIF
  938. CALL ECROBJ('TABLE ',MTABLE)
  939. RETURN
  940.  
  941. ELSE IF (CMOT.EQ.'FORM'.OR.CMOT.EQ.'CONS'.OR.CMOT.EQ.'ELEM'.OR.
  942. $ CMOT.EQ.'MATE'.OR.CMOT.EQ.'NON_') THEN
  943. INFOR=1
  944. IF (CMOT.EQ.'MATE') THEN
  945. IPASS=0
  946. ICOND=0
  947. 1191 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  948. IF (IERR.NE.0) RETURN
  949. IPASS=IPASS+1
  950. IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN
  951. CALL NOVARD(IPMODL,CMOT)
  952. RETURN
  953. ENDIF
  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 1191
  961. ENDIF
  962. ELSE
  963. ICOND=1
  964. 1192 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  965. IF (IERR.NE.0) RETURN
  966. ICOND=0
  967. IF (IRETO.NE.0) THEN
  968. INFOR=INFOR+1
  969. IF (INFOR.GT.NBFORM) THEN
  970. CALL ERREUR(5)
  971. RETURN
  972. ENDIF
  973. GO TO 1192
  974. ENDIF
  975. ENDIF
  976. INFOR=INFOR-1
  977. C
  978. JGN=4
  979. JGM=0
  980. SEGINI MLMOTS
  981. MLNONL=MLMOTS
  982. C
  983. MMODE1=IPMODL
  984. SEGACT MMODE1
  985. NSOUS=MMODE1.KMODEL(/1)
  986. N1=NSOUS
  987. SEGINI MMODEL
  988. IPP1=MMODEL
  989. NZON=0
  990. C
  991. C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  992. C partie
  993. IF (NSOUS .EQ. 0) THEN
  994. SEGDES MMODEL
  995. C SEGDES MMODE1
  996. CALL ECROBJ('MMODEL',IPP1)
  997. RETURN
  998. ELSE
  999. DO 1119 I=1,NSOUS
  1000. IMODEL=MMODE1.KMODEL(I)
  1001. SEGACT IMODEL
  1002. IF(CMOT.EQ.'FORM') THEN
  1003. NFOR=FORMOD(/2)
  1004.  
  1005. IF(NFOR.NE.INFOR) GO TO 1119
  1006. IF(NFOR.EQ.1) THEN
  1007. IF(MOFORM(1).NE.FORMOD(1)) GO TO 1119
  1008. ELSE IF(NFOR.EQ.2) THEN
  1009. IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE.
  1010. $ FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND.
  1011. $ (MOFORM(2).NE.FORMOD(1))))GO TO 1119
  1012. ELSE
  1013. GO TO 1118
  1014. ENDIF
  1015. ELSE IF (CMOT.EQ.'CONS') THEN
  1016. DO 425 IJ=1,INFOR
  1017. C on enleve les espaces au debut et a la fin
  1018. idim0=LEN(MOFORM(IJ))
  1019. idim1=CONMOD(/1)
  1020. ideb0=0
  1021. ifin0=0
  1022. ideb1=0
  1023. ifin1=0
  1024. DO ii=1,idim0
  1025. IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ')
  1026. $ ideb0=ii
  1027. IF(ifin0.EQ.0.AND.
  1028. & MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ')
  1029. & ifin0=idim0-ii+1
  1030. ENDDO
  1031. DO ii=1,idim1
  1032. IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii
  1033. IF(ifin1.EQ.0.AND.
  1034. & CONMOD(idim1-ii+1:idim1-ii+1).NE.' ')
  1035. & ifin1=idim1-ii+1
  1036. ENDDO
  1037. C print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1
  1038. IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1))
  1039. & GOTO 429
  1040. 425 CONTINUE
  1041. GO TO 1119
  1042. ELSE IF (CMOT.EQ.'ELEM') THEN
  1043. DO 426 IJ=1,INFOR
  1044. IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GO TO 429
  1045. 426 CONTINUE
  1046. GO TO 1119
  1047. ELSEIF(CMOT.EQ.'MATE') THEN
  1048. NMAT=MATMOD(/2)
  1049. DO 427 IJ=1,INFOR
  1050. DO 4275 JJ=1,NMAT
  1051. IF(MATMOD(JJ).EQ.MOFORM(IJ)) GO TO 429
  1052. 4275 CONTINUE
  1053. 427 CONTINUE
  1054. GO TO 1119
  1055. ELSEIF(CMOT.EQ.'NON_') THEN
  1056. MN3=INFMOD(/1)
  1057. IF(MN3.LE.12) GO TO 1119
  1058. INLOC=-1*INFMOD(13)
  1059. IF(INLOC.EQ.0) GO TO 1119
  1060. CALL MODNLO(MNLOCA,NLODIM)
  1061. DO 428 IJ=1,INFOR
  1062. IF(MNLOCA(INLOC).EQ.MOFORM(IJ)(1:4)) GO TO 429
  1063. 428 CONTINUE
  1064. GO TO 1119
  1065. ENDIF
  1066. C on vient ici pour prendre les sous modeles
  1067. 429 CONTINUE
  1068. NZON=NZON+1
  1069. NFOR=FORMOD(/2)
  1070. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  1071. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  1072. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  1073. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  1074. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  1075. SEGINI,IMODE1= IMODEL
  1076. IMODE1.INFMOD(2)=0
  1077. C SEGDES IMODEL
  1078. IMODEL=IMODE1
  1079. ENDIF
  1080. KMODEL(NZON)=IMODEL
  1081. C SEGDES IMODEL
  1082. 1119 CONTINUE
  1083. ENDIF
  1084. C
  1085. IF(NZON.EQ.0) GO TO 1118
  1086. N1=NZON
  1087. SEGADJ MMODEL
  1088. SEGDES MMODEL
  1089. C SEGDES MMODE1
  1090. CALL ECROBJ('MMODEL',IPP1)
  1091. RETURN
  1092. 1118 CONTINUE
  1093. CALL ERREUR(610)
  1094. SEGSUP MMODEL
  1095. C SEGDES IMODEL
  1096. C SEGDES MMODE1
  1097. RETURN
  1098.  
  1099. ELSE IF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN
  1100. CALL NOVARD(IPMODL,CMOT)
  1101. RETURN
  1102.  
  1103. ELSE IF (IRET.EQ.22) THEN
  1104. JGN=4
  1105. JGM=0
  1106. SEGINI MLMOTS
  1107. MLNONL=MLMOTS
  1108. C
  1109. MMODE1=IPMODL
  1110. SEGACT MMODE1
  1111. NSOUS=MMODE1.KMODEL(/1)
  1112. C
  1113. C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  1114. C partie
  1115. IF (NSOUS .EQ. 0) THEN
  1116. SEGDES MMODE1
  1117. SEGDES MLMOTS
  1118. CALL ECROBJ('LISTMOTS',MLNONL)
  1119. RETURN
  1120. ELSE
  1121. DO 1122 I=1,NSOUS
  1122. IMODEL=MMODE1.KMODEL(I)
  1123. SEGACT IMODEL
  1124. NFOR=FORMOD(/2)
  1125. IF(NFOR.GE.1) THEN
  1126. IF (FORMOD(1).NE.'MECANIQUE'.AND.
  1127. & FORMOD(1).NE.'POREUX') GO TO 1123
  1128. MN3=INFMOD(/1)
  1129. IF(MN3.LE.12) GO TO 1123
  1130. INONL=INFMOD(14)
  1131. IF(INONL.EQ.0) GO TO 1123
  1132. MLMOT1=INONL
  1133. SEGACT MLMOT1
  1134. NMONL=MLMOT1.MOTS(/2)
  1135. IF(NMONL.EQ.0)THEN
  1136. SEGDES MLMOT1
  1137. GO TO 1123
  1138. ENDIF
  1139. IF(JGM.EQ.0) THEN
  1140. JGM=NMONL
  1141. SEGADJ, MLMOTS
  1142. DO IJ=1,NMONL
  1143. MOTS(IJ)=MLMOT1.MOTS(IJ)
  1144. ENDDO
  1145. ELSE
  1146. DO IJ=1,NMONL
  1147. CALL PLACE(MOTS,JGM,IPLA,MLMOT1.MOTS(IJ))
  1148. IF(IPLA.EQ.0) THEN
  1149. JGM=JGM+1
  1150. SEGADJ, MLMOTS
  1151. MOTS(JGM)=MLMOT1.MOTS(IPLA)
  1152. ENDIF
  1153. ENDDO
  1154. ENDIF
  1155. SEGDES MLMOT1
  1156. 1123 CONTINUE
  1157. ENDIF
  1158. C SEGDES IMODEL
  1159. 1122 CONTINUE
  1160. SEGDES MMODE1
  1161. SEGDES MLMOTS
  1162. CALL ECROBJ('LISTMOTS',MLNONL)
  1163. RETURN
  1164. ENDIF
  1165. ELSE
  1166. MOTERR(1:4)=CMOT
  1167. CALL ERREUR(7)
  1168. RETURN
  1169. ENDIF
  1170.  
  1171.  
  1172. * +-------------------------------------------------------------------+
  1173. * | |
  1174. * | C H A R G E M E N T |
  1175. * | |
  1176. * +-------------------------------------------------------------------+
  1177. ELSE IF (CTYP.EQ.'CHARGEME') THEN
  1178. CALL LIROBJ('CHARGEME',ICHAR,1,IRET)
  1179. IF (IERR.NE.0) RETURN
  1180. C
  1181. CMOT = ' '
  1182. ICHGT = 0
  1183. LCHGT = 0
  1184. IEC = 1
  1185. CALL LIROBJ('LISTMOTS',LCHGT,0,IRET)
  1186. IF (IERR.NE.0) RETURN
  1187. IF (IRET.EQ.0) THEN
  1188. CALL LIRCHA(CMOT,1,IRETOU)
  1189. IF (IERR.NE.0) RETURN
  1190. CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT)
  1191. IF (ICHGT.GE.1 .AND. ICHGT.LE.5) THEN
  1192. CALL LIRENT(IEC,0,IRETOU)
  1193. IF (IERR.NE.0) RETURN
  1194. IF (IRETOU.EQ.0) IEC = 1
  1195. ELSE IF (ICHGT.EQ.0) THEN
  1196. CALL LIRCHA(MOT_4,0,IRETOU)
  1197. IF (IRETOU.NE.0) THEN
  1198. IF (MOT_4.EQ.'TABL') THEN
  1199. ICHGT=-1
  1200. ELSE
  1201. CALL REFUS
  1202. ENDIF
  1203. ENDIF
  1204. ENDIF
  1205. ENDIF
  1206. C
  1207. CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8)
  1208. C
  1209. IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1)
  1210. IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2)
  1211. RETURN
  1212.  
  1213.  
  1214. * +-------------------------------------------------------------------+
  1215. * | |
  1216. * | L I S T C H P O |
  1217. * | |
  1218. * +-------------------------------------------------------------------+
  1219. ELSE IF (CTYP.EQ.'LISTCHPO') THEN
  1220. CALL LIROBJ('LISTCHPO',ILCHP1,1,IRET)
  1221. IF (IERR.NE.0) RETURN
  1222. CALL QUETYP(CTYP1,0,IRETOU)
  1223. IF (IRETOU.EQ.0) THEN
  1224. CALL ERREUR(533)
  1225. RETURN
  1226. ENDIF
  1227.  
  1228. MLCHP1 = ILCHP1
  1229. SEGACT , MLCHP1
  1230. LONCHP = MLCHP1.ICHPOI(/1)
  1231.  
  1232. * ===============================
  1233. * EXTRACTION DE PLUSIEURS INDICES
  1234. * ===============================
  1235. IF (CTYP1.EQ.'LISTENTI') THEN
  1236. CALL LIROBJ('LISTENTI',ILENT,1,IRET)
  1237. IF (IERR.NE.0) GOTO 1212
  1238. MLENTI = ILENT
  1239. SEGACT,MLENTI
  1240. JG = LECT(/1)
  1241. N1=JG
  1242. SEGINI,MLCHP2
  1243. ILCHP2= MLCHP2
  1244. DO 1211 I=1 , JG
  1245. IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN
  1246. INTERR(1) = LECT(I)
  1247. CALL ERREUR(620)
  1248. ENDIF
  1249. MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I))
  1250. 1211 CONTINUE
  1251. SEGDES,MLENTI
  1252. SEGDES,MLCHP1
  1253. SEGDES,MLCHP2
  1254. CALL ECROBJ ('LISTCHPO',ILCHP2)
  1255. RETURN
  1256.  
  1257. * ===========================
  1258. * EXTRACTION D'UN SEUL INDICE
  1259. * ===========================
  1260. ELSEIF (CTYP1.EQ.'ENTIER') THEN
  1261. CALL LIRENT(ILENT,1,IRETOU)
  1262. IF (IERR.NE.0) GOTO 1212
  1263. IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN
  1264. INTERR(1)=ILENT
  1265. CALL ERREUR(620)
  1266. ENDIF
  1267. ILCHPO = MLCHP1.ICHPOI(ILENT)
  1268. SEGDES,MLCHP1
  1269. CALL ECROBJ('CHPOINT ',ILCHPO)
  1270. RETURN
  1271.  
  1272. * ====================================================
  1273. * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN UN POINT
  1274. * ====================================================
  1275. ELSEIF (CTYP1.EQ.'MOT') THEN
  1276. CALL LIRCHA(CMOT,1,IRETOU)
  1277. IF (IERR.NE.0) GOTO 1212
  1278. IF (CMOT.NE.'VALE') THEN
  1279. MOTERR(1:4) = 'VALE'
  1280. CALL ERREUR(396)
  1281. GOTO 1212
  1282. ENDIF
  1283. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  1284. IF (IRETOU.EQ.0) THEN
  1285. CALL LIRCHA(MOT_4,0,IRETOU)
  1286. IF (IRETOU.GT.0) THEN
  1287. JGN=4
  1288. JGM=1
  1289. SEGINI,MLMOTS
  1290. MOTS(1)=MOT_4
  1291. SEGDES,MLMOTS
  1292. ENDIF
  1293. ENDIF
  1294. CALL LIROBJ('POINT',MPOINT,1,IRETOU)
  1295. IF (IERR.NE.0) GOTO 1212
  1296. CALL EXTR24(MLCHP1,MLMOTS,MPOINT,MLREEL)
  1297. IF (IERR.NE.0) RETURN
  1298. SEGDES,MLCHP1
  1299. SEGDES,MLREEL
  1300. CALL ECROBJ('LISTREEL',MLREEL)
  1301. RETURN
  1302.  
  1303. * SYNTAXE INCORRECTE
  1304. ELSE
  1305. MOTERR(1:40) = 'ENTIER LISTENTI"VALE"'
  1306. CALL ERREUR(471)
  1307. GOTO 1212
  1308. ENDIF
  1309. C
  1310. C (erreur lors du traitement du LISTCHPO)
  1311. C
  1312. 1212 SEGDES,MLCHP1
  1313. RETURN
  1314.  
  1315.  
  1316. * +-------------------------------------------------------------------+
  1317. * | |
  1318. * | N U A G E |
  1319. * | |
  1320. * +-------------------------------------------------------------------+
  1321. ELSE IF (CTYP.EQ.'NUAGE') THEN
  1322. CALL LIROBJ('NUAGE ',IPOINT,1,IRET)
  1323. IF (IERR.NE.0) RETURN
  1324.  
  1325. MNUAGE=IPOINT
  1326. SEGACT MNUAGE
  1327. CALL LIRMOT(NUMO,5,INU1,0)
  1328. IF (INU1.EQ.0) THEN
  1329. CALL LIRCHA(CTYP1,1,IRETOU)
  1330. IF (IERR.NE.0) THEN
  1331. C SEGDES MNUAGE
  1332. RETURN
  1333. ENDIF
  1334. CALL LIRMOT(NUMO,5,INU1,0)
  1335. IF (INU1.EQ.0) THEN
  1336. IF (CTYP1.EQ.'COMP ') THEN
  1337. IPROG = 1
  1338. ELSE
  1339. IPOSI = 0
  1340. DO 1250 I=1,NUANOM(/2)
  1341. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1342. 1250 CONTINUE
  1343. IF (IPOSI.EQ.0) THEN
  1344. C SEGDES MNUAGE
  1345. MOTERR(1:8) = CTYP1
  1346. C TYP1 n'est pas un nom de variable du NUAGE
  1347. CALL ERREUR(672)
  1348. RETURN
  1349. ENDIF
  1350. IPROG = 2
  1351. ENDIF
  1352. ELSE
  1353. IPOSI = 0
  1354. DO 1251 I=1,NUANOM(/2)
  1355. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1356. 1251 CONTINUE
  1357. IF (IPOSI.EQ.0) THEN
  1358. C SEGDES MNUAGE
  1359. MOTERR(1:8) = CTYP1
  1360. C TYP1 n'est pas un nom de variable du NUAGE
  1361. CALL ERREUR(672)
  1362. RETURN
  1363. ENDIF
  1364. IPROG = 3
  1365. ENDIF
  1366. ELSE
  1367. CALL LIRCHA(CTYP1,1,IRETOU)
  1368. IF (IERR.NE.0) THEN
  1369. C SEGDES MNUAGE
  1370. RETURN
  1371. ENDIF
  1372. IPOSI = 0
  1373. DO 1252 I=1,NUANOM(/2)
  1374. IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1375. 1252 CONTINUE
  1376. IF (IPOSI.EQ.0) THEN
  1377. C SEGDES,MNUAGE
  1378. MOTERR(1:8) = CTYP1
  1379. C TYP1 n'est pas un nom de variable du NUAGE
  1380. CALL ERREUR(672)
  1381. RETURN
  1382. ELSE
  1383. IPROG = 3
  1384. ENDIF
  1385. ENDIF
  1386.  
  1387. C-------------- Lecture eventuelle des FLOTTANTS -------------
  1388. IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN
  1389. IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN
  1390. CALL LIRREE(XVAL1,0,IRETOU)
  1391. IF (IRETOU.EQ.0) THEN
  1392. C SEGDES,MNUAGE
  1393. C Il manque la valeur de la composante reelle
  1394. CALL ERREUR(668)
  1395. RETURN
  1396. ENDIF
  1397. ELSE
  1398. CALL LIRREE(XVAL1,0,IRETO1)
  1399. CALL LIRREE(XVAL2,0,IRETO2)
  1400. IF ((IRETO1.EQ.0).OR.(IRETO2.EQ.0)) THEN
  1401. C SEGDES,MNUAGE
  1402. C Il faut specifier deux valeurs reelles
  1403. CALL ERREUR(673)
  1404. RETURN
  1405. ENDIF
  1406. ENDIF
  1407. ENDIF
  1408. C SEGDES MNUAGE
  1409.  
  1410. C--------- Cas de l'extraction des noms des composantes du NUAGE -------
  1411. IF (IPROG.EQ.1) THEN
  1412. CALL EXTR19(IPOINT,IPLSTM)
  1413. IF (IPLSTM.NE.0) THEN
  1414. CALL ECROBJ('LISTMOTS',IPLSTM)
  1415. ENDIF
  1416.  
  1417. C----Cas de l'extraction de l'objet correspondant a une composante ---
  1418. C----------------- donnee d'un NUAGE "colonne" -----------------------
  1419.  
  1420. ELSE IF (IPROG.EQ.2) THEN
  1421. CALL EXTR51(IPOINT,IPOSI)
  1422.  
  1423. C---------------------------- Autres cas ------------------------------
  1424. ELSE IF (IPROG.EQ.3) THEN
  1425. IF (INU1.EQ.1) THEN
  1426. BORINF=.TRUE.
  1427. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1428. ELSE IF (INU1.EQ.2) THEN
  1429. BORINF=.FALSE.
  1430. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1431. ELSE IF (INU1.EQ.3) THEN
  1432. MINI =.TRUE.
  1433. CALL EXTR52(IPOINT,MINI,IPOSI)
  1434. ELSE IF (INU1.EQ.4) THEN
  1435. MINI =.FALSE.
  1436. CALL EXTR52(IPOINT,MINI,IPOSI)
  1437. ELSE IF (INU1.EQ.5) THEN
  1438. CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
  1439. ELSE
  1440. CALL ERREUR(21)
  1441. RETURN
  1442. ENDIF
  1443.  
  1444. C---------------------------- Cas non prevus ---------------------------
  1445. ELSE
  1446. CALL ERREUR(21)
  1447. RETURN
  1448. ENDIF
  1449. RETURN
  1450.  
  1451. ENDIF
  1452.  
  1453.  
  1454. ***********************************************************************
  1455. * ON TRAITE LES LISTENTI, LISTREEL ET LISTMOTS SEPAREMENT POUR *
  1456. * POUVOIR TOLERER L'INVERSION DES DEUX ARGUMENTS (LA LISTE PRINCIPALE *
  1457. * ET L'INDICE/LA LISTE D'INDICES) *
  1458. ***********************************************************************
  1459.  
  1460.  
  1461. * +-------------------------------------------------------------------+
  1462. * | |
  1463. * | L I S T M O T S |
  1464. * | |
  1465. * +-------------------------------------------------------------------+
  1466. 10 CONTINUE
  1467. CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET)
  1468. IF (IRET.EQ.0) GOTO 20
  1469.  
  1470. MLMOT1 = ILMOT1
  1471. SEGACT , MLMOT1
  1472. LONMOT = MLMOT1.MOTS(/2)
  1473. JGN = MLMOT1.MOTS(/1)
  1474.  
  1475. * ===============================
  1476. * EXTRACTION DE PLUSIEURS INDICES
  1477. * ===============================
  1478. CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1479. IF ( IRET .EQ. 1 ) THEN
  1480. MLENTI = ILENT
  1481. SEGACT , MLENTI
  1482. JGM = LECT(/1)
  1483. SEGINI , MLMOT2
  1484. ILMOT2= MLMOT2
  1485. DO 1221 I=1 , JGM
  1486. IF (( LECT(I) .GT. LONMOT ) .OR. ( LECT(I) .LT. 1 )) THEN
  1487. INTERR(1) = LECT(I)
  1488. CALL ERREUR(620)
  1489. ENDIF
  1490. MLMOT2.MOTS(I) = MLMOT1.MOTS(LECT(I))
  1491. 1221 CONTINUE
  1492. SEGDES , MLENTI
  1493. SEGDES , MLMOT1
  1494. SEGDES , MLMOT2
  1495. CALL ECROBJ ('LISTMOTS',ILMOT2)
  1496. RETURN
  1497.  
  1498. * ===========================
  1499. * EXTRACTION D'UN SEUL INDICE
  1500. * ===========================
  1501. ELSE
  1502. CALL LIRENT (ILENT,1,IRETOU)
  1503. IF (IERR .NE. 0) THEN
  1504. SEGDES , MLMOT1
  1505. RETURN
  1506. ENDIF
  1507. IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN
  1508. INTERR(1)=ILENT
  1509. CALL ERREUR(620)
  1510. ELSE
  1511. CTEXT = MLMOT1.MOTS(ILENT)
  1512. ENDIF
  1513. SEGDES , MLMOT1
  1514. CALL ECRCHA(CTEXT(1:JGN))
  1515. RETURN
  1516. ENDIF
  1517.  
  1518.  
  1519. * +-------------------------------------------------------------------+
  1520. * | |
  1521. * | L I S T R E E L |
  1522. * | |
  1523. * +-------------------------------------------------------------------+
  1524. 20 CONTINUE
  1525. CALL LIROBJ('LISTREEL',ILREE1,0,IRET)
  1526. IF (IRET.EQ.0) GOTO 30
  1527.  
  1528. MLREE1 = ILREE1
  1529. SEGACT , MLREE1
  1530. LONREE = MLREE1.PROG(/1)
  1531.  
  1532. * ===============================
  1533. * EXTRACTION DE PLUSIEURS INDICES
  1534. * ===============================
  1535. CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1536. IF ( IRET .EQ. 1 ) THEN
  1537. MLENTI = ILENT
  1538. SEGACT , MLENTI
  1539. JG = LECT(/1)
  1540. SEGINI , MLREE2
  1541. ILREE2= MLREE2
  1542. DO 1231 I=1 , JG
  1543. IF (( LECT(I) .GT. LONREE ) .OR. ( LECT(I) .LT. 1 )) THEN
  1544. INTERR(1) = LECT(I)
  1545. CALL ERREUR(620)
  1546. ENDIF
  1547. MLREE2.PROG(I) = MLREE1.PROG(LECT(I))
  1548. 1231 CONTINUE
  1549. SEGDES , MLENTI
  1550. SEGDES , MLREE1
  1551. SEGDES , MLREE2
  1552. CALL ECROBJ ('LISTREEL',ILREE2)
  1553. RETURN
  1554.  
  1555. * ===========================
  1556. * EXTRACTION D'UN SEUL INDICE
  1557. * ===========================
  1558. ELSE
  1559. CALL LIRENT (ILENT,1,IRETOU)
  1560. IF (IERR .NE. 0) THEN
  1561. SEGDES , MLREE1
  1562. RETURN
  1563. ENDIF
  1564. IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN
  1565. INTERR(1)=ILENT
  1566. CALL ERREUR(620)
  1567. ELSE
  1568. REELDP = MLREE1.PROG(ILENT)
  1569. ENDIF
  1570. SEGDES , MLREE1
  1571. CALL ECRREE(REELDP)
  1572. RETURN
  1573. ENDIF
  1574. 124 CONTINUE
  1575.  
  1576.  
  1577. * +-------------------------------------------------------------------+
  1578. * | |
  1579. * | L I S T E N T I |
  1580. * | |
  1581. * +-------------------------------------------------------------------+
  1582. 30 CONTINUE
  1583. CALL LIROBJ('LISTENTI',ILENT1,0,IRET)
  1584. IF (IRET.EQ.0) GOTO 999
  1585.  
  1586. MLENT1 = ILENT1
  1587. SEGACT , MLENT1
  1588. LONENT = MLENT1.LECT(/1)
  1589.  
  1590. * ===============================
  1591. * EXTRACTION DE PLUSIEURS INDICES
  1592. * ===============================
  1593. CALL LIROBJ('LISTENTI',ILENT2,0,IRET)
  1594. IF ( IRET .EQ. 1 ) THEN
  1595. MLENT2 = ILENT2
  1596. SEGACT , MLENT2
  1597. JG = MLENT2.LECT(/1)
  1598. SEGINI , MLENT3
  1599. ILENT3= MLENT3
  1600. DO 1241 I=1 , JG
  1601. IF (MLENT2.LECT(I).GT.LONENT.OR.MLENT2.LECT(I).LT.1) THEN
  1602. INTERR(1) = MLENT2.LECT(I)
  1603. CALL ERREUR(620)
  1604. ENDIF
  1605. MLENT3.LECT(I) = MLENT1.LECT(MLENT2.LECT(I))
  1606. 1241 CONTINUE
  1607. SEGDES , MLENT1
  1608. SEGDES , MLENT2
  1609. SEGDES , MLENT3
  1610. CALL ECROBJ ('LISTENTI',ILENT3)
  1611. RETURN
  1612.  
  1613. * ===========================
  1614. * EXTRACTION D'UN SEUL INDICE
  1615. * ===========================
  1616. ELSE
  1617. CALL LIRENT (ILENT,1,IRETOU)
  1618. IF (IERR .NE. 0) THEN
  1619. SEGDES , MLENT1
  1620. RETURN
  1621. ENDIF
  1622. IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN
  1623. INTERR(1)=ILENT
  1624. CALL ERREUR(620)
  1625. ELSE
  1626. INTEGR = MLENT1.LECT(ILENT)
  1627. ENDIF
  1628. SEGDES , MLENT1
  1629. CALL ECRENT(INTEGR)
  1630. RETURN
  1631. ENDIF
  1632.  
  1633.  
  1634.  
  1635.  
  1636. * +-------------------------------------------------------------------+
  1637. * | 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 |
  1638. * +-------------------------------------------------------------------+
  1639. 999 CONTINUE
  1640. CALL ERREUR(676)
  1641.  
  1642.  
  1643.  
  1644.  
  1645. RETURN
  1646. END
  1647.  
  1648.  
  1649.  
  1650.  

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