Télécharger la plaquette Cast3M


fr en

Télécharger extrai.eso

Retour à la liste

Numérotation des lignes : 

extrai

  1. C EXTRAI    SOURCE    PV090527  25/01/07    18:18:24     12116          
  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 PPARAM
  24. -INC CCOPTIO
  25. -INC CCGEOME
  26. -INC CCHAMP
  27. -INC SMCOORD
  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. -INC SMLOBJE
  44. -INC SMCHAML
  45.  
  46.       SEGMENT LIMODE(0)
  47.  
  48.       PARAMETER (NBFORM=100 , NBCHGT=10)
  49.       PARAMETER (NLOMAX=5, NBCMOC=25)
  50.       CHARACTER*4 MNLOCA(NLOMAX)
  51.       CHARACTER*4 CAMPL(1), MOOPT(7), NOMU(3), LMOSU(5), MOTBAS(5),
  52.      &     NUMO(5), MCHGT(NBCHGT), CMOC(NBCMOC), CFROT(1)
  53.       CHARACTER*16 MOFORM(NBFORM)
  54.       CHARACTER*4 MOT_4
  55.       CHARACTER*(LOCOMP) CMOT,MOT1,MOT2,MOCOMP
  56.       CHARACTER*8 MOT_8,CTYP,CTYP1
  57.       CHARACTER*(LOCHAI) CTEXTL,CTEXT
  58.       CHARACTER*(LCONMO) MOT_CM
  59.       LOGICAL LTELQ, LAG,BORINF,MINI,IMFRO,ZHARM
  60. C
  61.       DATA LMOSU /'RIGI','ELEM','RIGT','MASS','BLOQ'/
  62.       DATA NOMU  /'NOMU','MULT','UNIL'/
  63.       DATA MOOPT /'MAIL','RIGI','SYME','ANTI','CONT','COMP','DIAG'/
  64.       DATA MOTBAS/'RIGI','MASS','MODE','STAT','PSMO'/
  65.       DATA CAMPL /'AMPL'/
  66.       DATA NUMO  /'INFE','SUPE','MINI','MAXI','ENTR'/
  67.       DATA CMOC  /'MAIL','ZONE','FORM','CONS','ELEM','GEOM','CONT',
  68.      $            'DEFO','DEPL','FORC','GRAD','GRAF','MATE','CONP',
  69.      $            'TEMP','VARI','PARA','DEIN','COMP','OBJE','NON_',
  70.      $            'NLOC','PHAS','CENT','HHO_'/
  71.       DATA CFROT /'FROT'/
  72.       DATA MCHGT /'CHAR','CHAM','TRAJ','EVOL','VITE','COMP',
  73.      &            'LIE ','LIBR','LOBJ','LREE'/
  74.  
  75.       XVAL1=0.D0
  76.       MOT_4='    '
  77.       MINI =.FALSE.
  78.       ILO  =0
  79.       IOBIN=0
  80.       IVALRE=0
  81. C
  82.       CALL QUETYP(CTYP,0,IRETOU)
  83.       IF (IRETOU.EQ.0) THEN
  84.          CALL ERREUR(533)
  85.          RETURN
  86.       ENDIF
  87.  
  88. * +-------------------------------------------------------------------+
  89. * |                                                                   |
  90. * |                             M   O   T                             |
  91. * |                                                                   |
  92. * +-------------------------------------------------------------------+
  93.       IF (CTYP.EQ.'MOT     ') THEN
  94.          CALL LIRCHA(CTEXTL,1,LONMOT)
  95.          IF (IERR.NE.0) RETURN
  96.  
  97. *        ============================
  98. *        EXTRACTION D'UNE SOUS-CHAINE
  99. *        ============================
  100.          CALL QUETYP(CTYP1,0,IRETOU)
  101.          IF (IRETOU.NE.0) THEN
  102.             IF (CTYP1.EQ.'ENTIER'.OR.CTYP1.EQ.'LISTENTI') THEN
  103.                CALL SOUCHA(CTEXTL,LONMOT,CTYP1)
  104.                RETURN
  105.             ENDIF
  106.          ENDIF
  107.  
  108. *        ========================================================
  109. *        CREATION D'UNE TABLE CONTENANT LES OBJETS DE TYPE CTEXTL
  110. *        ========================================================
  111.          MOT_8=CTEXTL(1:8)
  112.          CALL REPERT(MOT_8,IA)
  113.          M=IA
  114.          SEGINI MTABLE
  115.          MLOTAB=0
  116.          DO 7765 I=1,IA
  117.             IF(MOT_8.EQ.'FLOTTANT' ) THEN
  118.                CALL LIRREE(XVAL,1,IRETOU)
  119.             ELSEIF(MOT_8.EQ.'LOGIQUE ') THEN
  120.                CALL LIRLOG(LAG,1,IRETOU)
  121.             ELSEIF (MOT_8.EQ.'ENTIER  ') THEN
  122.                CALL LIRENT(IVAL,1,IRETOU)
  123.             ELSEIF(MOT_8.EQ.'MOT     ') THEN
  124.                CALL LIRCHA(CTEXT,1,IRETOU)
  125.             ELSE
  126.                CALL LIROBJ(MOT_8,IVAL,1,IRETOU)
  127.             ENDIF
  128.             CALL ECCTAB(MTABLE,'ENTIER  ',I,XVAL1,MOT_4,MINI,ILO,
  129.      $           MOT_8,IVAL,XVAL,CTEXT(1:IRETOU),LAG,IVAL)
  130.  7765    CONTINUE
  131.          SEGDES MTABLE
  132.          CALL ECROBJ('TABLE   ',MTABLE)
  133.          RETURN
  134.  
  135.  
  136. * +-------------------------------------------------------------------+
  137. * |                                                                   |
  138. * |                   D   E   F   O   R   M   E   E                   |
  139. * |                                                                   |
  140. * +-------------------------------------------------------------------+
  141.       ELSEIF (CTYP.EQ.'DEFORME ') THEN
  142.          CALL LIROBJ('DEFORME ',MDEFOR,1,IRETOU)
  143.          IF(IERR.NE.0) RETURN
  144.          CALL LIRMOT(CAMPL,1,IRET,1)
  145.          IF(IERR.NE.0) RETURN
  146.          SEGACT MDEFOR
  147.          IF (AMPL(/1).NE.1) THEN
  148.             CALL ERREUR(475)
  149.          ELSE
  150.             AMP=AMPL(1)
  151.             CALL ECRREE(AMP)
  152.          ENDIF
  153.          RETURN
  154.  
  155.  
  156. * +-------------------------------------------------------------------+
  157. * |                                                                   |
  158. * |                   B   A   S   E   M   O   D   A                   |
  159. * |                                                                   |
  160. * +-------------------------------------------------------------------+
  161.       ELSEIF (CTYP.EQ.'BASEMODA') THEN
  162.          CALL LIROBJ('BASEMODA',IPBASE,1,IRETOU)
  163.          IF(IERR.NE.0) RETURN
  164.          CALL LIRMOT(MOTBAS,5,IRET,1)
  165.          IF(IERR.NE.0) RETURN
  166.          MOT_4=MOTBAS(IRET)
  167.          CALL EXTRA7(IPBASE,MOT_4,IPTR)
  168.          IF(IERR.NE.0) RETURN
  169.          IF (IRET.LE.2) THEN
  170.             CALL ECROBJ('RIGIDITE',IPTR)
  171.          ELSE
  172.             CALL ECROBJ('SOLUTION',IPTR)
  173.          ENDIF
  174.          RETURN
  175.  
  176.  
  177. * +-------------------------------------------------------------------+
  178. * |                                                                   |
  179. * |                 E   V   O   L   U   T   I   O   N                 |
  180. * |                                                                   |
  181. * +-------------------------------------------------------------------+
  182.       ELSEIF (CTYP.EQ.'EVOLUTIO') THEN
  183.          CALL LIROBJ('EVOLUTIO',IBOLL,1,IRETOU)
  184.          CALL ACTOBJ('EVOLUTIO',IBOLL,1)
  185.          IF(IERR.NE.0) RETURN
  186.          CALL EXTRA6 (IBOLL)
  187.          RETURN
  188.  
  189.  
  190. * +-------------------------------------------------------------------+
  191. * |                                                                   |
  192. * |                   S   U   P   E   R   E   L   E                   |
  193. * |                                                                   |
  194. * +-------------------------------------------------------------------+
  195.       ELSEIF (CTYP.EQ.'SUPERELE') THEN
  196.          CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU)
  197.          IF (IERR.NE.0) RETURN
  198.          CALL LIRMOT(LMOSU,5,IRET,1)
  199.          IF (IERR.NE.0) RETURN
  200.          SEGACT MSUPER
  201.  
  202. *        ==============
  203. *        MOT-CLE "RIGI"
  204. *        ==============
  205.          IF (IRET.EQ.1) THEN
  206.             IPTR=MSURAI
  207.             CALL ECROBJ('RIGIDITE',IPTR)
  208.  
  209. *        ==============
  210. *        MOT-CLE "ELEM"
  211. *        ==============
  212.          ELSEIF (IRET.EQ.2) THEN
  213.             IPTR=MSUPEL
  214.             CALL ECROBJ('MAILLAGE',IPTR)
  215.  
  216. *        ==============
  217. *        MOT-CLE "RIGT"
  218. *        ==============
  219.          ELSEIF (IRET.EQ.3) THEN
  220.             IPTR=MRIGTO
  221.             CALL ECROBJ('RIGIDITE',IPTR)
  222.  
  223. *        ==============
  224. *        MOT-CLE "MASS"
  225. *        ==============
  226.          ELSEIF (IRET.EQ.4) THEN
  227.             IPTR=MSUMAS
  228.             CALL ECROBJ('RIGIDITE',IPTR)
  229.  
  230. *        ==============
  231. *        MOT-CLE "BLOQ"
  232. *        ==============
  233.          ELSEIF (IRET.EQ.5) THEN
  234.             NRIGEL=MBLOQU
  235.             RI1=MRIGTO
  236.             SEGACT,RI1
  237.             SEGINI,MRIGID
  238.             MTYMAT=RI1.MTYMAT
  239.             DO 1 IE1=1,NRIGEL
  240.                COERIG(IE1)=RI1.COERIG(IE1)
  241.                DO 11 IE2=1,8
  242.                   IRIGEL(IE2,IE1)=RI1.IRIGEL(IE2,IE1)
  243.  11            CONTINUE
  244.  1          CONTINUE
  245.             SEGACT,MRIGID
  246.             CALL ECROBJ('RIGIDITE',MRIGID)
  247.          ENDIF
  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=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=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=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.             SEGACT,MELEME
  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.          CALL ACTOBJ('MAILLAGE',IPP1,1)
  468.          CALL ECROBJ('MAILLAGE',IPP1)
  469.          RETURN
  470.  
  471.  
  472. * +-------------------------------------------------------------------+
  473. * |                                                                   |
  474. * |                     C   H   P   O   I   N   T                     |
  475. * |                                                                   |
  476. * +-------------------------------------------------------------------+
  477.       ELSEIF (CTYP.EQ.'CHPOINT') THEN
  478.          CALL LIROBJ('CHPOINT ',IBOPOI,1,IRETOU)
  479.          IF (IERR.NE.0) RETURN
  480.          CALL ACTOBJ('CHPOINT ',IBOPOI,1)
  481.          IF (IERR.NE.0) RETURN
  482.          CALL LIRCHA(CMOT,1,IRETOU)
  483.          IF (IERR.NE.0) RETURN
  484.          MOT_4=CMOT
  485.  
  486. *        =====================================
  487. *        MOT-CLE "TITR" => EXTRACTION DU TITRE
  488. *        =====================================
  489.          IF (MOT_4.EQ.'TITR') THEN
  490.             MCHPOI = IBOPOI
  491.             CTEXT = MOCHDE
  492.             ILON = LEN(CTEXT)
  493.             DO 100 I = ILON,1,-1
  494.                IF (CTEXT(I:I).NE.' ') THEN
  495.                   NLON = I
  496.                   GOTO 102
  497.                ENDIF
  498.  100        CONTINUE
  499.             NLON = 1
  500.  102        CONTINUE
  501.             CALL ECRCHA(CTEXT(1:NLON))
  502.             RETURN
  503.  
  504. *        =========================================
  505. *        MOT-CLE "NATU" => EXTRACTION DE LA NATURE
  506. *        =========================================
  507.          ELSEIF (MOT_4.EQ.'NATU') THEN
  508.             MCHPOI = IBOPOI
  509.             INAT = JATTRI(1)
  510.             IF (INAT.EQ.0) CTEXT(1:11) = 'INDETERMINE'
  511.             IF (INAT.EQ.1) CTEXT(1:11) = 'DIFFUS     '
  512.             IF (INAT.EQ.2) CTEXT(1:11) = 'DISCRET    '
  513.             CALL ECRCHA(CTEXT(1:11))
  514.             RETURN
  515.  
  516. *        ===================================================
  517. *        MOT-CLE "MAIL" => EXTRACTION DU SUPPORT GEOMETRIQUE
  518. *        ===================================================
  519.          ELSEIF (MOT_4 .EQ.'MAIL') THEN
  520.             IMUL=0
  521.             CALL LIRMOT(NOMU,1,IMUL,0)
  522.             IF (IERR.NE.0) RETURN
  523.             CALL EXTR21(IBOPOI,IMUL,IPP1)
  524.             IF (IERR.NE.0) RETURN
  525.             CALL ACTOBJ('MAILLAGE',IPP1,1)
  526.             CALL ECROBJ('MAILLAGE',IPP1)
  527.             RETURN
  528.  
  529. *        ========================================================
  530. *        MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  531. *        ========================================================
  532.          ELSEIF (MOT_4 .EQ.'COMP') THEN
  533.             CALL EXTR11(IBOPOI,KLISTM)
  534.             CALL ECROBJ('LISTMOTS',KLISTM)
  535.             RETURN
  536.  
  537. *        ====================================
  538. *        MOT-CLE "TYPE" => EXTRACTION DU TYPE
  539. *        ====================================
  540.          ELSEIF (MOT_4.EQ.'TYPE') THEN
  541.             MCHPOI = IBOPOI
  542.             MOT_8 = MTYPOI
  543.             CALL ECRCHA(MOT_8(1:8))
  544.             RETURN
  545.  
  546. *        ============================================================
  547. *        MOT-CLE "VALE" => EXTRACTION DES VALEURS EN PLUSIEURS POINTS
  548. *                          ET POUR PLUSIEURS COMPOSANTES
  549. *        ============================================================
  550.          ELSEIF (MOT_4.EQ.'VALE') THEN
  551. *
  552. *           LISTE DES COMPOSANTES (OBJET MOT OU LISTMOTS)
  553.             CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  554.             IF (IRETOU.EQ.1) THEN
  555.               SEGACT,MLMOTS
  556.  
  557.             ELSE
  558.                CALL LIRCHA(MOCOMP,0,IRETOU)
  559.                IF (IRETOU.GT.0) THEN
  560.                   JGN=LOCOMP
  561.                   JGM=1
  562.                   SEGINI,MLMOTS
  563.                   MOTS(1)=MOCOMP
  564.                   SEGACT,MLMOTS
  565.                ENDIF
  566.             ENDIF
  567. *
  568. *           LISTE DES NOEUDS (OBJET POINT OU MAILLAGE DE POI1)
  569.             CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  570.             IF (IRETOU.EQ.1) THEN
  571.               CALL ACTOBJ('MAILLAGE',MELEME,1)
  572.             ELSE
  573.                CALL LIROBJ('POINT',IPOINT,0,IRETOU)
  574.                IF (IRETOU.NE.0) THEN
  575.                   CALL CRELEM(IPOINT)
  576.                   MELEME=IPOINT
  577.                ENDIF
  578.             ENDIF
  579. *
  580. *           MOT-CLE 'NOID'
  581.             IVID=0
  582.             CALL LIRCHA(MOT_4,0,IRETOU)
  583.             IF (IRETOU.NE.0) THEN
  584.                IF (MOT_4.EQ.'NOID') THEN
  585.                   IVID=1
  586.                ELSE
  587.                   MOTERR(1:4)=MOT_4
  588.                   MOTERR(5:40)='NOID'
  589.                   CALL ERREUR(1052)
  590.                   RETURN
  591.                ENDIF
  592.             ENDIF
  593. *
  594. *           APPEL A EXTR23
  595.             CALL EXTR23(IBOPOI,MLMOTS,MELEME,MLREEL,IVID)
  596.             IF (IERR.NE.0) RETURN
  597.             SEGACT,MLREEL
  598.             CALL ECROBJ('LISTREEL',MLREEL)
  599.             RETURN
  600.  
  601. *        ===========================================================
  602. *        PAS DE MOT CLE : CMOT = NOM DE COMPOSANTE
  603. *        EXTRACTION DE LA VALEUR EN UN POINT D'UNE COMPOSANTE DONNEE
  604. *        ===========================================================
  605.          ELSE
  606.              CALL LIROBJ('POINT   ',MPOINT,1,IRETOU)
  607.              IF (IRETOU.EQ.0) THEN
  608.                  MOTERR(1:8)='POINT'
  609.                  CALL ERREUR(37)
  610.                  RETURN
  611.              ENDIF
  612. c            lecture facultative de l'harmonique de Fourier
  613.              CALL LIRENT(NHARM,0,IRET)
  614.              ZHARM=IRET.EQ.1
  615.              CALL EXTRA9(IBOPOI,MPOINT,CMOT,NHARM,ZHARM,XFLOT,IRET)
  616.              CALL ECRREE(XFLOT)
  617.              RETURN
  618.          ENDIF
  619.  
  620.  
  621.  
  622. * +-------------------------------------------------------------------+
  623. * |                                                                   |
  624. * |                       M   C   H   A   M   L                       |
  625. * |                                                                   |
  626. * +-------------------------------------------------------------------+
  627.       ELSEIF (CTYP.EQ.'MCHAML') THEN
  628.          CALL LIROBJ('MCHAML  ',IPCHE1,1,IRET)
  629.          CALL ACTOBJ('MCHAML  ',IPCHE1,1)
  630.          IF (IERR.NE.0) RETURN
  631. C
  632.          CALL LIRCHA(CMOT,1,IRET0)
  633.          IF (IERR.NE.0) RETURN
  634.          MOT_4=CMOT
  635.  
  636.  
  637. *        ================================================
  638. *        MOTS-CLES "DEVA" OU "COVA" => NOMS DES VARIABLES
  639. *        ================================================
  640.          IF (MOT_4.EQ.'DEVA' .OR. MOT_4.EQ.'COVA') THEN
  641.             CALL EXCHA1(IPCHE1,ILISR,MOT_4)
  642.             IF (ILISR.NE.0) THEN
  643.               CALL ACTOBJ('LISTMOTS',ILISR,1)
  644.               CALL ECROBJ('LISTMOTS',ILISR)
  645.             ENDIF
  646.             RETURN
  647.  
  648. *        =================================
  649. *        MOT-CLE "NBZO" => NOMBRE DE ZONES
  650. *        =================================
  651.          ELSEIF (MOT_4.EQ.'NBZO') THEN
  652.             CALL EXTR18(IPCHE1,NBZONE)
  653.             if (ierr.ne.0) return
  654.             CALL ECRENT(NBZONE)
  655.             RETURN
  656.  
  657. *        =====================================================
  658. *        MOT-CLE "COMP" => EXTRACTION DES NOMS DES COMPOSANTES
  659. *        =====================================================
  660.          ELSEIF (MOT_4.EQ.'COMP' ) THEN
  661.             CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  662. C
  663. C           RECHERCHE DES NOMS DES COMPOSANTES APPARTENANT
  664. C           A LA ZONE DU MODELE
  665.             IF (IRETM.NE.0) THEN
  666.                CALL ACTOBJ('MMODEL',IPMODL,1)
  667.                CALL EXTR15(IPMODL,IPCHE1,IPLSTM)
  668.                IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  669.                RETURN
  670. C
  671. C           RECHERCHE DES NOMS DE TOUTES LES COMPOSANTES
  672.             ELSE
  673.                CALL EXTR17(IPCHE1,IPLSTM)
  674.                CALL ECROBJ('LISTMOTS',IPLSTM)
  675.                RETURN
  676.             ENDIF
  677.  
  678. *        ======================================================
  679. *        MOT-CLE "CONS" => EXTRACTION DES NOMS DES CONSTITUANTS
  680. *        ======================================================
  681.          ELSEIF(MOT_4.EQ.'CONS' ) THEN
  682.             CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  683. C
  684. C           RECHERCHE DES NOMS DES CONSTITUANTS APPARTENANT
  685. C           A LA ZONE DU MODELE
  686.             IF (IRETM.NE.0) THEN
  687.                CALL ACTOBJ('MMODEL',IPMODL,1)
  688.                CALL EXTR35(IPMODL,IPCHE1,IPLSTM)
  689.                IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  690.                RETURN
  691. C
  692. C           RECHERCHE DES NOMS DE TOUs LES constituants
  693.             ELSE
  694.                CALL EXTR37(IPCHE1,IPLSTM)
  695.                CALL ECROBJ('LISTMOTS',IPLSTM)
  696.                RETURN
  697.             ENDIF
  698.  
  699. *        =========================================================
  700. *        EXTRACTION DE LA VALEUR, DU TITRE, DU TYPE OU DU MAILLAGE
  701. *        =========================================================
  702.          ELSE
  703.             IF (MOT_4.NE.'TITR'.AND.MOT_4.NE.'TYPE'.AND.
  704.      &          MOT_4.NE.'MAIL') THEN
  705.                IENT1 = 0
  706.                IENT2 = 0
  707.                IENT3 = 0
  708.                IPMAIL = 0
  709.                CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET0)
  710.                IF (IRET0.NE.0) THEN
  711.                  CALL ACTOBJ('MAILLAGE',IPMAIL,1)
  712.                  IF (IERR.NE.0) RETURN
  713.                  MELEME = IPMAIL
  714.                  NBEL1 = NUM(/2)
  715.                  IF (NBEL1.NE.1) THEN
  716.                    CALL ERREUR(426)
  717.                    RETURN
  718.                  ENDIF
  719.                  IENT3 = 0
  720.                  CALL LIRENT(IENT3,0,IRET3)
  721.                  IF (IRET3.NE.0.AND.IENT3.LE.0) THEN
  722.                    INTERR(1) = IENT3
  723.                    CALL ERREUR(36)
  724.                    RETURN
  725.                  ENDIF
  726.                ELSE
  727.                  IPMAIL = 0
  728.                  CALL LIRENT(IENT1,1,IRET1)
  729.                  IF(IRET1.EQ.0) RETURN
  730.                  IF (IENT1.LE.0) THEN
  731.                    INTERR(1) = IENT1
  732.                    CALL ERREUR(36)
  733.                    RETURN
  734.                  ENDIF
  735.                  CALL LIRENT(IENT2,1,IRET2)
  736.                  IF(IRET2.EQ.0) RETURN
  737.                  IF (IENT2.LE.0) THEN
  738.                    INTERR(1) = IENT2
  739.                    CALL ERREUR(36)
  740.                    RETURN
  741.                  ENDIF
  742.                  CALL LIRENT(IENT3,1,IRET3)
  743.                  IF(IRET3.EQ.0) RETURN
  744.                  IF (IENT3.LE.0) THEN
  745.                    INTERR(1) = IENT3
  746.                    CALL ERREUR(36)
  747.                    RETURN
  748.                  ENDIF
  749.                ENDIF
  750.             ENDIF
  751.             CALL EXTR14(IPCHE1,IENT1,IENT2,IENT3,CMOT,IPMAIL)
  752.             RETURN
  753.          ENDIF
  754.  
  755.  
  756. * +-------------------------------------------------------------------+
  757. * |                                                                   |
  758. * |                       M   M   O   D   E   L                       |
  759. * |                                                                   |
  760. * +-------------------------------------------------------------------+
  761.       ELSEIF (CTYP.EQ.'MMODEL') THEN
  762.          CALL LIROBJ('MMODEL',IPMODL,1,IRET)
  763.          CALL ACTOBJ('MMODEL',IPMODL,1)
  764.          IF (IERR.NE.0) RETURN
  765.          CALL LIRMOT(CMOC,NBCMOC,IRET,1)
  766.          IF(IERR.NE.0) RETURN
  767.          CMOT  =CMOC(IRET)
  768.          MOT_4 =CMOT
  769.  
  770. C        Extension du MMODEL en cas de modele de MELANGE
  771.          CALL MODETE(IPMODL,MMODEL,IMELAN)
  772.          NSOUS=MMODEL.KMODEL(/1)
  773.  
  774. C=DEB==== FORMULATION HHO ==== Cas particulier =========================
  775.          IF (MOT_4.EQ.'HHO_') THEN
  776.            CALL REFUS
  777.            CALL LIRCHA(CTEXT,1,iret)
  778.            IF (IERR.NE.0) RETURN
  779.            CALL HHOEXT(IPMODL,CTEXT, IPP1,CTYP,iret)
  780.            IF (iret.NE.0) THEN
  781.              CALL ERREUR(iret)
  782.              RETURN
  783.            END IF
  784.            IF (IPP1.LE.0) THEN
  785.              CALL ERREUR(21)
  786.              RETURN
  787.            END IF
  788.            CALL ACTOBJ(CTYP,IPP1,1)
  789.            CALL ECROBJ(CTYP,IPP1)
  790.            RETURN
  791.          END IF
  792. C=FIN==== FORMULATION HHO ==============================================
  793.  
  794.          IF (MOT_4.EQ.'MAIL') THEN
  795.             IMFRO=.FALSE.
  796.             CALL LIRMOT(CFROT,1,IRET,0)
  797.             IF (IRET.EQ.1) THEN
  798.               IMFRO=.TRUE.
  799.             ENDIF
  800.               IPP1=0
  801.                   ltelq=.false.
  802.                 DO 1116 I=1,NSOUS
  803.                   IMODEL= KMODEL(I)
  804.                  IF (IMFRO) THEN
  805.                   NMATT=MATMOD(/2)
  806.                   CALL PLACE(MATMOD,NMATT,IPLAC,'FROTTANT')
  807.                   if(iplac.eq.0) goto 1116
  808.                  ENDIF
  809.                   IPP2  = IMAMOD
  810.                   IF (ipp1.eq.0) then
  811.                     ipp1=ipp2
  812.                   ELSE
  813.                     CALL FUSE (IPP1,IPP2,IRET,ltelq)
  814.                     IPP1=IRET
  815.                   ENDIF
  816.  1116           CONTINUE
  817.  
  818.             IF(IPP1.EQ.0) THEN
  819. C             Cas du resultat 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.             ENDIF
  828.             CALL ACTOBJ('MAILLAGE',IPP1,1)
  829.             CALL ECROBJ('MAILLAGE',IPP1)
  830.             RETURN
  831.  
  832.          ELSEIF (MOT_4.eq.'COMP') THEN
  833.             CALL LIRCHA(MOFORM(1),1,iretou)
  834.             if(ierr.ne.0) return
  835.             N1=0
  836.             SEGINI,MMODE1
  837.             DO 5497 I=1,NSOUS
  838.               IMODEL=KMODEL(I)
  839.               DO IB=1,MATMOD(/2)
  840.                 IF( MATMOD(IB) .EQ. MOFORM(1) ) GOTO 5498
  841.               ENDDO
  842.               GOTO 5497
  843.  5498         CONTINUE
  844.               N1=N1+1
  845.               MMODE1.KMODEL(**)=KMODEL(I)
  846.  5497       CONTINUE
  847.  
  848.             IF(N1.GE.0.AND.N1.LT.NSOUS) THEN
  849.               SEGADJ,MMODE1
  850.  
  851.             ELSEIF(N1.EQ.NSOUS)THEN
  852. C             Pas la peine de creer un autre MMODEL
  853.               SEGSUP,MMODE1
  854.               MMODE1=MMODEL
  855.  
  856.             ELSE
  857.               CALL ERREUR(5)
  858.             ENDIF
  859.  
  860.             CALL ACTOBJ('MMODEL  ',MMODE1,1)
  861.             CALL ECROBJ('MMODEL  ',MMODE1)
  862.             RETURN
  863.  
  864.          ELSEIF(MOT_4.EQ.'OBJE') THEN
  865.             if(NSOUS.ne.1) then
  866.                WRITE(IOIMP,*) ' Dans extrai.eso : '
  867.                WRITE(IOIMP,*) ' ce n est pas un modele elementaire'
  868.                WRITE(IOIMP,*) ' it is not an elementary model'
  869.                call erreur(19)
  870.                return
  871.             endif
  872.             imodel=kmodel(1)
  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.             return
  884.  
  885.          ELSEIF (MOT_4.EQ.'ZONE') THEN
  886. C- Option 'ZONE' 'CONS' => IZOCO=1
  887.             IZOCO = 0
  888.             CALL LIRMOT(CMOC(4),1,IZOCO,0)
  889.             IF (IERR.NE.0) RETURN
  890.  
  891.             INCTS = 2
  892.             IF (IZOCO.EQ.1) INCTS = 3
  893.             M = INCTS * NSOUS
  894.             N1 = 1
  895.             SEGINI MTABLE
  896.  
  897.             DO IOK=1,NSOUS
  898.               IMODEL=KMODEL(IOK)
  899.               NFOR=FORMOD(/2)
  900. C      CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  901.               CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  902.               CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  903.               CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  904.               IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  905.                 SEGINI,IMODE1=IMODEL
  906.                 IMODE1.INFMOD(2)=0
  907.                 IMODEL=IMODE1
  908.               ENDIF
  909.               SEGINI MMODE1
  910.               MMODE1.KMODEL(1) = IMODEL
  911.               IVALI1 = (IOK-1)*INCTS + 1
  912.               IPP1   = MMODE1
  913.               CALL ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
  914.      $                 IOBIN,'MMODEL  ',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  915.               IVALI1 = IVALI1 + 1
  916.               IPP1   = IMAMOD
  917.               CALL ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
  918.      $                 IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  919.               IF (IZOCO.EQ.1) THEN
  920.                 IVALI1 = IVALI1 + 1
  921.                 MOT_CM = CONMOD
  922.                 CALL ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
  923.      $                   IOBIN,'MOT     ',IVALRE,XFLOT,MOT_CM,LAG,IPP1)
  924.               ENDIF
  925. C              SEGDES IMODEL
  926.             ENDDO
  927.  
  928.             CALL ECROBJ('TABLE   ',MTABLE)
  929.             RETURN
  930.  
  931.          ELSEIF (MOT_4.EQ.'FORM'.OR.MOT_4.EQ.'CONS'.OR.MOT_4.EQ.'ELEM'
  932.      &    .OR. MOT_4.EQ.'MATE'.OR.MOT_4.EQ.'NON_'
  933.      &    .OR.MOT_4.EQ.'PHAS') THEN
  934.             INFOR=1
  935.             IF (MOT_4.EQ.'MATE'.OR.MOT_4.EQ.'PHAS') THEN
  936.                IPASS=0
  937.                ICOND=0
  938.  1191          CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  939.                IF (IERR.NE.0) RETURN
  940.                IPASS=IPASS+1
  941.                IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN
  942.                   CALL NOVARD(MMODEL,MOT_4)
  943.                   RETURN
  944.                ENDIF
  945.                IF (IRETO.NE.0) THEN
  946.                   INFOR=INFOR+1
  947.                   IF (INFOR.GT.NBFORM) THEN
  948.                      CALL ERREUR(5)
  949.                      RETURN
  950.                   ENDIF
  951.                   GOTO 1191
  952.                ENDIF
  953.             ELSE
  954.                ICOND=1
  955.  1192          CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  956.                IF (IERR.NE.0) RETURN
  957.                ICOND=0
  958.                IF (IRETO.NE.0) THEN
  959.                   INFOR=INFOR+1
  960.                   IF (INFOR.GT.NBFORM) THEN
  961.                      CALL ERREUR(5)
  962.                      RETURN
  963.                   ENDIF
  964.                   GOTO 1192
  965.                ENDIF
  966.             ENDIF
  967.             INFOR=INFOR-1
  968. C
  969.             JGN=4
  970.             JGM=0
  971.             SEGINI MLMOTS
  972.             MLNONL=MLMOTS
  973. C
  974.             MMODE1=MMODEL
  975.  
  976.             IF (NSOUS .EQ. 0) THEN
  977. C             TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  978. C             partie
  979.               CALL ECROBJ('MMODEL  ',IPMODL)
  980.               RETURN
  981.  
  982.             ELSE
  983.               N1=NSOUS
  984.               SEGINI,MMODEL
  985.               IPP1=MMODEL
  986.               NZON=0
  987.               IMECAF=0
  988.               DO 1119 I=1,NSOUS
  989.                  IMODEL=MMODE1.KMODEL(I)
  990.                  IF(MOT_4.EQ.'FORM') THEN
  991.                     NFOR=FORMOD(/2)
  992.  
  993.                     IF(NFOR.NE.INFOR) GOTO 1119
  994.                     IF(NFOR.EQ.1) THEN
  995.                        IF(MOFORM(1).NE.FORMOD(1)) GOTO 1119
  996.                     ELSEIF(NFOR.EQ.2) THEN
  997.                        IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE.
  998.      $                    FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND.
  999.      $                    (MOFORM(2).NE.FORMOD(1))))GOTO 1119
  1000.                     ELSE
  1001.                        GOTO 1118
  1002.                     ENDIF
  1003.                  ELSEIF (MOT_4.EQ.'CONS') THEN
  1004.                      DO 425 IJ=1,INFOR
  1005. C                    on enleve les espaces au debut et a la fin
  1006.                        idim0=LEN(MOFORM(IJ))
  1007.                        idim1=CONMOD(/1)
  1008.                        ideb0=0
  1009.                        ifin0=0
  1010.                        ideb1=0
  1011.                        ifin1=0
  1012.                        DO ii=1,idim0
  1013.                          IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ')
  1014.      $                         ideb0=ii
  1015.                           IF(ifin0.EQ.0.AND.
  1016.      &                        MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ')
  1017.      &                        ifin0=idim0-ii+1
  1018.                       ENDDO
  1019.                       DO ii=1,idim1
  1020.                         IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii
  1021.                         IF(ifin1.EQ.0.AND.
  1022.      &                         CONMOD(idim1-ii+1:idim1-ii+1).NE.' ')
  1023.      &                         ifin1=idim1-ii+1
  1024.                        ENDDO
  1025. C                    print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1
  1026.                       IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1))
  1027.      &                     GOTO 429
  1028.  425                 CONTINUE
  1029.                    GOTO 1119
  1030.                  ELSEIF (MOT_4.EQ.'ELEM') THEN
  1031.                     DO 426 IJ=1,INFOR
  1032.                        IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GOTO 429
  1033.  426                CONTINUE
  1034.                     GOTO 1119
  1035.                  ELSEIF(MOT_4.EQ.'MATE') THEN
  1036.                     NMAT=MATMOD(/2)
  1037.                     DO 427 IJ=1,INFOR
  1038.                        DO 4275 JJ=1,NMAT
  1039.                          IF(MATMOD(JJ).EQ.MOFORM(IJ)) GOTO 429
  1040.  4275                  CONTINUE
  1041.  427                CONTINUE
  1042.                    GOTO 1119
  1043.                  ELSEIF(MOT_4.EQ.'NON_') THEN
  1044.                     MN3=INFMOD(/1)
  1045.                     IF(MN3.LE.12) GOTO 1119
  1046.                     INLOC=-1*INFMOD(13)
  1047.                     IF(INLOC.EQ.0) GOTO 1119
  1048.                     CALL MODNLO(MNLOCA,NLODIM)
  1049.                     DO 428 IJ=1,INFOR
  1050.                       IF(MNLOCA(INLOC).EQ.MOFORM(IJ)(1:4)) GOTO 429
  1051.  428                CONTINUE
  1052.                    GOTO 1119
  1053.                  ELSEIF(MOT_4.EQ.'PHAS'
  1054.      &                  .AND.CONMOD.NE.'                ') THEN
  1055.                         DO 430 IJ=1,INFOR
  1056.                         IF(CONMOD(17:24).EQ.MOFORM(IJ)(1:8)) GOTO 429
  1057. 430             CONTINUE
  1058.                     GOTO 1119
  1059.                  ENDIF
  1060. C     on vient ici pour prendre les sous modeles
  1061.  429             CONTINUE
  1062.                  NZON=NZON+1
  1063.                  NFOR=FORMOD(/2)
  1064.  
  1065. C                CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  1066.                  CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  1067.                  CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  1068.                  CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  1069.                  IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  1070.                     IMECAF=1
  1071.                     SEGINI,IMODE1=IMODEL
  1072.                     IMODE1.INFMOD(2)=0
  1073.                     IMODEL=IMODE1
  1074.                  ENDIF
  1075.  
  1076.                  KMODEL(NZON)=IMODEL
  1077.  1119        CONTINUE
  1078.             ENDIF
  1079. C
  1080.             IF(NZON.EQ.0) GOTO 1118
  1081.  
  1082.             IF(NZON.EQ.NSOUS .AND. IMECAF.EQ.0) THEN
  1083. C             Le SOUS-MODELE demande est le MODELE d'origine
  1084.               CALL ECROBJ('MMODEL  ',IPMODL)
  1085.  
  1086.             ELSE
  1087.               IF(NZON.NE.NSOUS)THEN
  1088.                 N1=NZON
  1089.                 SEGADJ,MMODEL
  1090.               ENDIF
  1091.               CALL ACTOBJ('MMODEL  ',IPP1,1)
  1092.               CALL ECROBJ('MMODEL  ',IPP1)
  1093.             ENDIF
  1094.             RETURN
  1095.  
  1096.  1118       CONTINUE
  1097.             CALL ERREUR(610)
  1098.             RETURN
  1099.  
  1100.          ELSEIF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN
  1101.             CALL NOVARD(MMODEL,MOT_4)
  1102.             RETURN
  1103.  
  1104.          ELSEIF (IRET.EQ.22) THEN
  1105.            JGN=4
  1106.            JGM=0
  1107.            SEGINI MLMOTS
  1108.            MLNONL=MLMOTS
  1109. C
  1110.            MMODE1=MMODEL
  1111.            NSOUS=MMODE1.KMODEL(/1)
  1112. C
  1113. C           TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  1114. C           partie
  1115.             IF (NSOUS .EQ. 0) THEN
  1116.               SEGACT,MLMOTS
  1117.               CALL ECROBJ('LISTMOTS',MLMOTS)
  1118.               RETURN
  1119.             ELSE
  1120.               DO 1122 I=1,NSOUS
  1121.                  IMODEL=MMODE1.KMODEL(I)
  1122.                  NFOR=FORMOD(/2)
  1123.                  IF(NFOR.GE.1) THEN
  1124.                     IF (FORMOD(1).NE.'MECANIQUE'.AND.
  1125.      &                  FORMOD(1).NE.'POREUX') GOTO 1123
  1126.                     MN3=INFMOD(/1)
  1127.                     IF(MN3.LE.12) GOTO 1123
  1128.                     INONL=INFMOD(14)
  1129.                     IF(INONL.EQ.0) GOTO 1123
  1130.                     MLMOT1=INONL
  1131.                     SEGACT MLMOT1
  1132.                     NMONL=MLMOT1.MOTS(/2)
  1133.                     IF(NMONL.EQ.0)GOTO 1123
  1134.                     IF(JGM.EQ.0) THEN
  1135.                       JGM=NMONL
  1136.                       SEGADJ,MLMOTS
  1137.                       DO IJ=1,NMONL
  1138.                         MOTS(IJ)=MLMOT1.MOTS(IJ)
  1139.                       ENDDO
  1140.                     ELSE
  1141.                       DO IJ=1,NMONL
  1142.                         CALL PLACE(MOTS,JGM,IPLA,MLMOT1.MOTS(IJ))
  1143.                         IF(IPLA.EQ.0) THEN
  1144.                           JGM=JGM+1
  1145.                           SEGADJ,MLMOTS
  1146.                           MOTS(JGM)=MLMOT1.MOTS(IPLA)
  1147.                         ENDIF
  1148.                       ENDDO
  1149.                     ENDIF
  1150. 1123                CONTINUE
  1151.                  ENDIF
  1152. 1122          CONTINUE
  1153.               SEGACT,MLMOTS
  1154.               CALL ECROBJ('LISTMOTS',MLMOTS)
  1155.               RETURN
  1156.             ENDIF
  1157. *
  1158.          ELSE IF (MOT_4.eq.'CENT') THEN
  1159. * pour NAVIER-STOKE NLIN, extrai les POINTS CENTRES
  1160.            ipma = 0
  1161. c
  1162.            L1 = 8
  1163.            n1 = 1
  1164.            segini mmode1
  1165.            n3 = 6
  1166.            segini mchel1
  1167.            n2 = 1
  1168.            segini mcham1
  1169.            mchel1.ichaml(1) = mcham1
  1170.            ipmons = mmode1
  1171.            ipchns = mchel1
  1172.            do is = 1,nsous
  1173.              imodel = kmodel(is)
  1174.              if (formod(1).eq.'NAVIER_STOKES'.and.matmod(1).eq.'NLIN')
  1175.      & then
  1176.                mmode1.kmodel(1) = imodel
  1177.                call go2nli(ipmons,ipchns,ipres,5)
  1178.                if (ierr.ne.0 ) return
  1179.              endif
  1180.              if (ipma.eq.0) then
  1181.                ipma = ipres
  1182.              else
  1183.                call fuse(ipma,ipres,ip3,.true.)
  1184.                if (ierr.ne.0) return
  1185.                ipma = ip3
  1186.              endif
  1187.            enddo
  1188.            segsup mchel1, mcham1, mmode1
  1189.            if (IPMA.GT.0) then
  1190.              call ecrobj('MAILLAGE',ipma)
  1191.              return
  1192.            else
  1193.              call erreur(21)
  1194.              return
  1195.            endif
  1196.          ELSE
  1197.             MOTERR=MOT_4
  1198.             CALL ERREUR(7)
  1199.             RETURN
  1200.          ENDIF
  1201.  
  1202.  
  1203. * +-------------------------------------------------------------------+
  1204. * |                                                                   |
  1205. * |               C   H   A   R   G   E   M   E   N   T               |
  1206. * |                                                                   |
  1207. * +-------------------------------------------------------------------+
  1208.       ELSEIF (CTYP.EQ.'CHARGEME') THEN
  1209.          CALL LIROBJ('CHARGEME',ICHAR,1,IRET)
  1210.          IF (IERR.NE.0) RETURN
  1211. C
  1212.          CMOT  = '    '
  1213.          ICHGT = 0
  1214.          LCHGT = 0
  1215.          IEC   = 1
  1216.          CALL LIROBJ('LISTMOTS',LCHGT,0,IRET)
  1217.          IF (IERR.NE.0) RETURN
  1218.          IF (IRET.EQ.0) THEN
  1219.             CALL LIRCHA(CMOT,1,IRETOU)
  1220.             IF (IERR.NE.0) RETURN
  1221.             CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT)
  1222.             IF ((ICHGT.GE.1 .AND. ICHGT.LE.5) .OR. ICHGT.GE.9) THEN
  1223.                CALL LIRENT(IEC,0,IRETOU)
  1224.                IF (IERR.NE.0) RETURN
  1225.                IF (IRETOU.EQ.0) IEC = 1
  1226.             ELSEIF (ICHGT.EQ.0) THEN
  1227.                CALL LIRCHA(MOT_4,0,IRETOU)
  1228.                IF (IRETOU.NE.0) THEN
  1229.                   IF (MOT_4.EQ.'TABL') THEN
  1230.                      ICHGT=-1
  1231.                   ELSE
  1232.                      CALL REFUS
  1233.                   ENDIF
  1234.                ENDIF
  1235.             ENDIF
  1236.          ENDIF
  1237. C
  1238.          CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8)
  1239. C
  1240.          IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1)
  1241.          IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2)
  1242.          RETURN
  1243.  
  1244.  
  1245. * +-------------------------------------------------------------------+
  1246. * |                                                                   |
  1247. * |                   L   I   S   T   C   H   P   O                   |
  1248. * |                                                                   |
  1249. * +-------------------------------------------------------------------+
  1250.       ELSEIF (CTYP.EQ.'LISTCHPO') THEN
  1251.          CALL LIROBJ('LISTCHPO',ILCHP1,1,IRET)
  1252.          IF (IERR.NE.0) RETURN
  1253.          CALL QUETYP(CTYP1,0,IRETOU)
  1254.          IF (IRETOU.EQ.0) THEN
  1255.             CALL ERREUR(533)
  1256.             RETURN
  1257.          ENDIF
  1258.  
  1259.          MLCHP1 = ILCHP1
  1260.          SEGACT , MLCHP1
  1261.          LONCHP = MLCHP1.ICHPOI(/1)
  1262.  
  1263. *        ===============================
  1264. *        EXTRACTION DE PLUSIEURS INDICES
  1265. *        ===============================
  1266.          IF (CTYP1.EQ.'LISTENTI') THEN
  1267.             CALL LIROBJ('LISTENTI',ILENT,1,IRET)
  1268.             IF (IERR.NE.0) RETURN
  1269.             MLENTI = ILENT
  1270.             SEGACT,MLENTI
  1271.             JG = LECT(/1)
  1272.             N1=JG
  1273.             SEGINI,MLCHP2
  1274.             ILCHP2= MLCHP2
  1275.             DO 1211 I=1 , JG
  1276.                IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN
  1277.                   INTERR(1) = LECT(I)
  1278.                   CALL ERREUR(620)
  1279.                ENDIF
  1280.                MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I))
  1281.  1211       CONTINUE
  1282.             CALL ACTOBJ ('LISTCHPO',ILCHP2,0)
  1283.             CALL ECROBJ ('LISTCHPO',ILCHP2)
  1284.             RETURN
  1285.  
  1286. *        ===========================
  1287. *        EXTRACTION D'UN SEUL INDICE
  1288. *        ===========================
  1289.          ELSEIF (CTYP1.EQ.'ENTIER') THEN
  1290.             CALL LIRENT(ILENT,1,IRETOU)
  1291.             IF (IERR.NE.0) RETURN
  1292.             IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN
  1293.                INTERR(1)=ILENT
  1294.                CALL ERREUR(620)
  1295.             ENDIF
  1296.             ILCHPO = MLCHP1.ICHPOI(ILENT)
  1297.             CALL ACTOBJ('CHPOINT ',ILCHPO,1)
  1298.             CALL ECROBJ('CHPOINT ',ILCHPO)
  1299.             RETURN
  1300.  
  1301. *        ====================================================
  1302. *        MOT-CLE "VALE" => EXTRACTION DES VALEURS EN UN POINT
  1303. *        ====================================================
  1304.          ELSEIF (CTYP1.EQ.'MOT') THEN
  1305.             CALL LIRCHA(CMOT,1,IRETOU)
  1306.             IF (IERR.NE.0) RETURN
  1307.             IF (CMOT.NE.'VALE') THEN
  1308.                 MOTERR = 'VALE'
  1309.                 CALL ERREUR(396)
  1310.                 RETURN
  1311.             ENDIF
  1312.             CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  1313.             IF (IRETOU.EQ.0) THEN
  1314.                 CALL LIRCHA(MOCOMP,0,IRETOU)
  1315.                 IF (IRETOU.GT.0) THEN
  1316.                     JGN=LOCOMP
  1317.                     JGM=1
  1318.                     SEGINI,MLMOTS
  1319.                     MOTS(1)=MOCOMP
  1320.                 ENDIF
  1321.             ENDIF
  1322.             CALL LIROBJ('POINT',MPOINT,1,IRETOU)
  1323.             IF (IERR.NE.0) RETURN
  1324.             CALL EXTR24(MLCHP1,MLMOTS,MPOINT,MLREEL)
  1325.             IF (IERR.NE.0) RETURN
  1326.             SEGACT,MLREEL
  1327.             CALL ECROBJ('LISTREEL',MLREEL)
  1328.             RETURN
  1329.  
  1330. *        SYNTAXE INCORRECTE
  1331.          ELSE
  1332.             MOTERR(1:40) = 'ENTIER  LISTENTI"VALE"'
  1333.             CALL ERREUR(471)
  1334.             RETURN
  1335.          ENDIF
  1336.  
  1337.  
  1338. * +-------------------------------------------------------------------+
  1339. * |                                                                   |
  1340. * |                         N   U   A   G   E                         |
  1341. * |                                                                   |
  1342. * +-------------------------------------------------------------------+
  1343.       ELSEIF (CTYP.EQ.'NUAGE') THEN
  1344.          CALL LIROBJ('NUAGE   ',IPOINT,1,IRET)
  1345.          CALL ACTOBJ('NUAGE   ',IPOINT,1)
  1346.          IF (IERR.NE.0) RETURN
  1347.  
  1348.          MNUAGE=IPOINT
  1349.          CALL LIRMOT(NUMO,5,INU1,0)
  1350.          IF (INU1.EQ.0) THEN
  1351.             CALL LIRCHA(CTYP1,1,IRETOU)
  1352.             IF (IERR.NE.0) THEN
  1353.                RETURN
  1354.             ENDIF
  1355.             CALL LIRMOT(NUMO,5,INU1,0)
  1356.             IF (INU1.EQ.0) THEN
  1357.                IF (CTYP1.EQ.'COMP    ') THEN
  1358.                   IPROG = 1
  1359.                ELSE
  1360.                   IPOSI = 0
  1361.                   DO 1250 I=1,NUANOM(/2)
  1362.                      IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1363.  1250             CONTINUE
  1364.                   IF (IPOSI.EQ.0) THEN
  1365.                      MOTERR(1:8) = CTYP1
  1366. C                    TYP1 n'est pas un nom de variable du NUAGE
  1367.                      CALL ERREUR(672)
  1368.                      RETURN
  1369.                   ENDIF
  1370.                   IPROG = 2
  1371.                ENDIF
  1372.             ELSE
  1373.                IPOSI = 0
  1374.                DO 1251 I=1,NUANOM(/2)
  1375.                   IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1376.  1251          CONTINUE
  1377.                IF (IPOSI.EQ.0) THEN
  1378.                   MOTERR(1:8) = CTYP1
  1379. C                 TYP1 n'est pas un nom de variable du NUAGE
  1380.                   CALL ERREUR(672)
  1381.                   RETURN
  1382.                ENDIF
  1383.                IPROG = 3
  1384.             ENDIF
  1385.          ELSE
  1386.             CALL LIRCHA(CTYP1,1,IRETOU)
  1387.             IF (IERR.NE.0) RETURN
  1388.             IPOSI = 0
  1389.             DO 1252 I=1,NUANOM(/2)
  1390.                IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1391.  1252       CONTINUE
  1392.             IF (IPOSI.EQ.0) THEN
  1393.                MOTERR= CTYP1
  1394. C              TYP1 n'est pas un nom de variable du NUAGE
  1395.                CALL ERREUR(672)
  1396.                RETURN
  1397.             ELSE
  1398.                IPROG = 3
  1399.             ENDIF
  1400.          ENDIF
  1401.  
  1402. C-------------- Lecture eventuelle des FLOTTANTS -------------
  1403.          IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN
  1404.             IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN
  1405.                CALL LIRREE(XVAL1,0,IRETOU)
  1406.                IF (IRETOU.EQ.0) THEN
  1407. C                 Il manque la valeur de la composante reelle
  1408.                   CALL ERREUR(668)
  1409.                   RETURN
  1410.                ENDIF
  1411.             ELSE
  1412.                CALL LIRREE(XVAL1,0,IRETO1)
  1413.                CALL LIRREE(XVAL2,0,IRETO2)
  1414.                IF ((IRETO1.EQ.0).OR.(IRETO2.EQ.0)) THEN
  1415. C                 Il faut specifier deux valeurs reelles
  1416.                   CALL ERREUR(673)
  1417.                   RETURN
  1418.                ENDIF
  1419.             ENDIF
  1420.          ENDIF
  1421.  
  1422. C--------- Cas de l'extraction des noms des composantes du NUAGE -------
  1423.          IF (IPROG.EQ.1) THEN
  1424.             CALL EXTR19(IPOINT,IPLSTM)
  1425.             IF (IPLSTM.NE.0) THEN
  1426.                CALL ECROBJ('LISTMOTS',IPLSTM)
  1427.             ENDIF
  1428.  
  1429. C----Cas de l'extraction de l'objet correspondant a une composante ---
  1430. C----------------- donnee d'un NUAGE "colonne" -----------------------
  1431.  
  1432.          ELSEIF (IPROG.EQ.2) THEN
  1433.             CALL EXTR51(IPOINT,IPOSI)
  1434.  
  1435. C---------------------------- Autres cas ------------------------------
  1436.          ELSEIF (IPROG.EQ.3) THEN
  1437.             IF (INU1.EQ.1) THEN
  1438.                BORINF=.TRUE.
  1439.                CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1440.             ELSEIF (INU1.EQ.2) THEN
  1441.                BORINF=.FALSE.
  1442.                CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1443.             ELSEIF (INU1.EQ.3) THEN
  1444.                MINI =.TRUE.
  1445.                CALL EXTR52(IPOINT,MINI,IPOSI)
  1446.             ELSEIF (INU1.EQ.4) THEN
  1447.                MINI =.FALSE.
  1448.                CALL EXTR52(IPOINT,MINI,IPOSI)
  1449.             ELSEIF (INU1.EQ.5) THEN
  1450.                CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
  1451.             ELSE
  1452.                 CALL ERREUR(21)
  1453.                 RETURN
  1454.             ENDIF
  1455.  
  1456. C---------------------------- Cas non prevus ---------------------------
  1457.          ELSE
  1458.             CALL ERREUR(21)
  1459.             RETURN
  1460.          ENDIF
  1461.          RETURN
  1462.  
  1463.  
  1464. * +-------------------------------------------------------------------+
  1465. * |                                                                   |
  1466. * |                          L I S T O B J E                          |
  1467. * |                                                                   |
  1468. * +-------------------------------------------------------------------+
  1469.       ELSEIF (CTYP.EQ.'LISTOBJE') THEN
  1470.         CALL LIROBJ('LISTOBJE',ILOBJ,1,IRET)
  1471.         IF (IERR.NE.0) RETURN
  1472.  
  1473. C EXTRACTION DU TYPE DES OBJETS DE LA LISTE
  1474.         CALL LIRCHA(CTEXT,0,IRET)
  1475.         IF (IRET.NE.0) THEN
  1476.           IF (CTEXT(1:4).EQ.'TYPE') THEN
  1477.             MLOBJE = ILOBJ
  1478.             SEGACT,MLOBJE
  1479.             CTYP = TYPOBJ
  1480.             CALL ECRCHA(CTYP)
  1481.             RETURN
  1482.           ENDIF
  1483.         ENDIF
  1484.  
  1485. C EXTRACTION D'UN OBJET DE LA LISTE
  1486.         CALL LIRENT(I1,1,IRET)
  1487.         IF (IERR.NE.0) RETURN
  1488.         IF (I1.LE.0) THEN
  1489.           CALL ERREUR(21)
  1490.           RETURN
  1491.         ENDIF
  1492.         MLOBJE = ILOBJ
  1493.         SEGACT,MLOBJE
  1494.         NOBJ = LISOBJ(/1)
  1495.         IF (I1.GT.NOBJ) THEN
  1496.           INTERR(1) = I1
  1497.           CALL ERREUR(620)
  1498.           RETURN
  1499.         ENDIF
  1500.         IP1  = LISOBJ(I1)
  1501.         CTYP = TYPOBJ
  1502.         CALL ECROBJ(CTYP,IP1)
  1503.         RETURN
  1504.  
  1505.  
  1506. C     FIN IF(CTYP...
  1507.       ENDIF
  1508.  
  1509.  
  1510. ***********************************************************************
  1511. * ON TRAITE LES LISTENTI, LISTREEL ET LISTMOTS SEPAREMENT POUR        *
  1512. * POUVOIR TOLERER L'INVERSION DES DEUX ARGUMENTS (LA LISTE PRINCIPALE *
  1513. * ET L'INDICE/LA LISTE D'INDICES)                                     *
  1514. ***********************************************************************
  1515.  
  1516.  
  1517. * +-------------------------------------------------------------------+
  1518. * |                                                                   |
  1519. * |                   L   I   S   T   M   O   T   S                   |
  1520. * |                                                                   |
  1521. * +-------------------------------------------------------------------+
  1522.    10 CONTINUE
  1523.       CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET)
  1524.       IF (IRET.EQ.0) GOTO 20
  1525.  
  1526.       MLMOT1 = ILMOT1
  1527.       SEGACT , MLMOT1
  1528.       LONMOT = MLMOT1.MOTS(/2)
  1529.       JGN = MLMOT1.MOTS(/1)
  1530.  
  1531. *     ===============================
  1532. *     EXTRACTION DE PLUSIEURS INDICES
  1533. *     ===============================
  1534.       CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1535.       IF ( IRET .EQ. 1 ) THEN
  1536.          MLENTI = ILENT
  1537.          SEGACT , MLENTI
  1538.          JGM = LECT(/1)
  1539.          SEGINI , MLMOT2
  1540.          ILMOT2= MLMOT2
  1541.          DO 1221 I=1 , JGM
  1542.            I_EXTR =LECT(I)
  1543.             IF (( I_EXTR .GT. LONMOT ) .OR. ( I_EXTR .LT. 1 )) THEN
  1544.                INTERR(1) = I_EXTR
  1545.                CALL ERREUR(620)
  1546.             ENDIF
  1547.             MLMOT2.MOTS(I) = MLMOT1.MOTS(I_EXTR)
  1548.  1221    CONTINUE
  1549.          SEGACT , MLMOT2
  1550.          CALL ECROBJ ('LISTMOTS',ILMOT2)
  1551.          RETURN
  1552.  
  1553. *     ===========================
  1554. *     EXTRACTION D'UN SEUL INDICE
  1555. *     ===========================
  1556.       ELSE
  1557.          CALL LIRENT (ILENT,1,IRETOU)
  1558.          IF (IERR .NE. 0) RETURN
  1559.          IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN
  1560.             INTERR(1)=ILENT
  1561.             CALL ERREUR(620)
  1562.          ELSE
  1563.             CTEXT = MLMOT1.MOTS(ILENT)
  1564.          ENDIF
  1565.          CALL ECRCHA(CTEXT(1:JGN))
  1566.          RETURN
  1567.       ENDIF
  1568.  
  1569.  
  1570. * +-------------------------------------------------------------------+
  1571. * |                                                                   |
  1572. * |                   L   I   S   T   R   E   E   L                   |
  1573. * |                                                                   |
  1574. * +-------------------------------------------------------------------+
  1575.    20 CONTINUE
  1576.       CALL LIROBJ('LISTREEL',ILREE1,0,IRET)
  1577.       IF (IRET.EQ.0) GOTO 30
  1578.  
  1579.       MLREE1 = ILREE1
  1580.       SEGACT , MLREE1
  1581.       LONREE = MLREE1.PROG(/1)
  1582.  
  1583. *     ===============================
  1584. *     EXTRACTION DE PLUSIEURS INDICES
  1585. *     ===============================
  1586.       CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1587.       IF ( IRET .EQ. 1 ) THEN
  1588.          MLENTI = ILENT
  1589.          SEGACT , MLENTI
  1590.          JG = LECT(/1)
  1591.          SEGINI , MLREE2
  1592.          ILREE2= MLREE2
  1593.          DO 1231 I=1 , JG
  1594.            I_EXTR =LECT(I)
  1595.             IF (( I_EXTR .GT. LONREE ) .OR. ( I_EXTR .LT. 1 )) THEN
  1596.                INTERR(1) = I_EXTR
  1597.                CALL ERREUR(620)
  1598.                RETURN
  1599.             ENDIF
  1600.             MLREE2.PROG(I) = MLREE1.PROG(I_EXTR)
  1601.  1231    CONTINUE
  1602.          SEGACT , MLREE2
  1603.          CALL ECROBJ ('LISTREEL',ILREE2)
  1604.          RETURN
  1605.  
  1606. *     ===========================
  1607. *     EXTRACTION D'UN SEUL INDICE
  1608. *     ===========================
  1609.       ELSE
  1610.          CALL LIRENT (ILENT,1,IRETOU)
  1611.          IF (IERR .NE. 0) RETURN
  1612.          IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN
  1613.             INTERR(1)=ILENT
  1614.             CALL ERREUR(620)
  1615.          ELSE
  1616.             REELDP = MLREE1.PROG(ILENT)
  1617.          ENDIF
  1618.          CALL ECRREE(REELDP)
  1619.          RETURN
  1620.       ENDIF
  1621.  124  CONTINUE
  1622.  
  1623.  
  1624. * +-------------------------------------------------------------------+
  1625. * |                                                                   |
  1626. * |                   L   I   S   T   E   N   T   I                   |
  1627. * |                                                                   |
  1628. * +-------------------------------------------------------------------+
  1629.    30 CONTINUE
  1630.       CALL LIROBJ('LISTENTI',ILENT1,0,IRET)
  1631.       IF (IRET.EQ.0) GOTO 999
  1632.  
  1633.       MLENT1 = ILENT1
  1634.       SEGACT , MLENT1
  1635.       LONENT = MLENT1.LECT(/1)
  1636.  
  1637. *     ===============================
  1638. *     EXTRACTION DE PLUSIEURS INDICES
  1639. *     ===============================
  1640.       CALL LIROBJ('LISTENTI',ILENT2,0,IRET)
  1641.       IF ( IRET .EQ. 1 ) THEN
  1642.          MLENT2 = ILENT2
  1643.          SEGACT , MLENT2
  1644.          JG = MLENT2.LECT(/1)
  1645.          SEGINI , MLENT3
  1646.          ILENT3= MLENT3
  1647.          DO I=1 , JG
  1648.             I_EXTR =MLENT2.LECT(I)
  1649.             IF (I_EXTR.GT.LONENT .OR. I_EXTR.LT.1) THEN
  1650.                INTERR(1) = I_EXTR
  1651.                CALL ERREUR(620)
  1652.             ENDIF
  1653.             MLENT3.LECT(I) = MLENT1.LECT(I_EXTR)
  1654.          ENDDO
  1655.          SEGACT , MLENT3
  1656.          CALL ECROBJ ('LISTENTI',ILENT3)
  1657.          RETURN
  1658.  
  1659. *     ===========================
  1660. *     EXTRACTION D'UN SEUL INDICE
  1661. *     ===========================
  1662.       ELSE
  1663.          CALL LIRENT (ILENT,1,IRETOU)
  1664.          IF (IERR .NE. 0) RETURN
  1665.          IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN
  1666.             INTERR(1)=ILENT
  1667.             CALL ERREUR(620)
  1668.          ELSE
  1669.             INTEGR = MLENT1.LECT(ILENT)
  1670.          ENDIF
  1671.          CALL ECRENT(INTEGR)
  1672.          RETURN
  1673.       ENDIF
  1674.  
  1675.  
  1676. * +-------------------------------------------------------------------+
  1677. * |   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   |
  1678. * +-------------------------------------------------------------------+
  1679.   999 CONTINUE
  1680.       CALL ERREUR(676)
  1681.  
  1682.       END
  1683.  
  1684.  
  1685.  
  1686.  
  1687.  
  1688.  
  1689.  

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