Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

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

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