Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

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

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