Télécharger extrai.eso

Retour à la liste

Numérotation des lignes :

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

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