Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

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

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