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    FD218221  25/12/14    21:15:02     12423          
  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. *                     ==> extension 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,0,IRET)
  268.                IF (IRET.NE.1) THEN
  269.                   CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,0,MLMOT2)
  270.                   IF (IERR.NE.0) RETURN
  271.                ENDIF
  272.             ELSE
  273.                CALL LIRCHA(MOT1,1,IRET)
  274.                IF (IERR.NE.0) RETURN
  275.                JGN=4
  276.                JGM=1
  277.                SEGINI MLMOT1
  278.                MLMOT1.MOTS(1)=MOT1
  279.                CALL LIRCHA(MOT2,0,IRET)
  280.                IF (IRET.EQ.0) THEN
  281.                   CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,0,MLMOT2)
  282.                   IF (IERR.NE.0) RETURN
  283.                ELSE
  284.                   SEGINI MLMOT2
  285.                   MLMOT2.MOTS(1)=MOT2
  286.                ENDIF
  287.             ENDIF
  288.             CALL EXINCK(IBOGID,MLMOT1,MLMOT2,IOUT,IMPR,IRET)
  289.             IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2
  290.             IF (IERR.NE.0) RETURN
  291.             CALL ECROBJ('MATRIK',IOUT)
  292.             RETURN
  293.  
  294. *        ============================================
  295. *        MOT-CLE "DIAG" => EXTRACTION DE LA DIAGONALE
  296. *        ============================================
  297.          ELSEIF (IRET.EQ.7) THEN
  298.             CALL ECROBJ('MATRIK',IBOGID)
  299.             CALL EXDIAG(1)
  300.             RETURN
  301.  
  302. *        =======================================================
  303. *        MOT-CLE "COMP => EXTRACTION DE LA LISTE DES COMPOSANTES
  304. *        =======================================================
  305.          ELSEIF(IRET.EQ.6) THEN
  306.             CALL LIRCHA(CMOT,0,ICDUAL)
  307.             IF (ICDUAL.NE.0) THEN
  308.                IF (CMOT.NE.'DUAL') THEN
  309.                   MOTERR=CMOT
  310.                   CALL ERREUR(7)
  311.                   RETURN
  312.                ENDIF
  313.             ENDIF
  314.             CALL EXTR26(IBOGID,ICDUAL,IPLSTM)
  315.             CALL ECROBJ('LISTMOTS',IPLSTM)
  316.             RETURN
  317.          ELSE
  318.             MOTERR=MOOPT(IRET)
  319.             CALL ERREUR(7)
  320.             RETURN
  321.          ENDIF
  322.  
  323.  
  324. * +-------------------------------------------------------------------+
  325. * |                                                                   |
  326. * |                   R   I   G   I   D   I   T   E                   |
  327. * |                                                                   |
  328. * +-------------------------------------------------------------------+
  329.       ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  330.          CALL LIROBJ ('RIGIDITE',IBOGID,1,IRETOU)
  331.          IF (IERR.NE.0) RETURN
  332.          CALL LIRMOT(MOOPT,7,IRET,0)
  333.  
  334. *        ====================================================
  335. *        EXTRACTION D'UNE SOUS-MATRICE DE COMPOSANTES DONNEES
  336. *        ====================================================
  337.          IF (IRET.EQ.0) THEN
  338.             CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM)
  339.             IF (IRETLM.EQ.1) THEN
  340.                CALL LIROBJ('LISTMOTS',MLMOT2,0,IRET)
  341.                IF (IRET.NE.1) THEN
  342.                   CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,1,MLMOT2)
  343.                   IF (IERR.NE.0) RETURN
  344.                ENDIF
  345.             ELSE
  346.                CALL LIRCHA(MOT1,1,IRET)
  347.                IF (IERR.NE.0) RETURN
  348.                JGN=4
  349.                JGM=1
  350.                SEGINI MLMOT1
  351.                MLMOT1.MOTS(1)=MOT1
  352.                CALL LIRCHA(MOT2,0,IRET)
  353.                IF (IRET.EQ.0) THEN
  354.                   CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,1,MLMOT2)
  355.                   IF (IERR.NE.0) RETURN
  356.                ELSE
  357.                   SEGINI MLMOT2
  358.                   MLMOT2.MOTS(1)=MOT2
  359.                ENDIF
  360.             ENDIF
  361.             CALL EXINCR(IBOGID,MLMOT1,MLMOT2,IOUT)
  362.             IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2
  363.             IF (IERR.NE.0) RETURN
  364.             CALL ECROBJ('RIGIDITE',IOUT)
  365.             RETURN
  366.  
  367. *        ============================================
  368. *        MOT-CLE "DIAG" => EXTRACTION DE LA DIAGONALE
  369. *        ============================================
  370.          ELSEIF (IRET.EQ.7) THEN
  371.             CALL EXDIAR(IBOGID,ICHP)
  372.             IF (IERR.NE.0) RETURN
  373.             CALL ACTOBJ('CHPOINT ',ICHP,1)
  374.             CALL ECROBJ('CHPOINT ',ICHP)
  375.             RETURN
  376.  
  377. *        ========================================================
  378. *        MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  379. *        ========================================================
  380.          ELSEIF(IRET.EQ.6) THEN
  381.             CALL LIRCHA(CMOT,0,ICDUAL)
  382.             IF (ICDUAL.NE.0) THEN
  383.                IF (CMOT.NE.'DUAL') THEN
  384.                   MOTERR=CMOT
  385.                   CALL ERREUR(7)
  386.                   RETURN
  387.                ENDIF
  388.             ENDIF
  389.             CALL EXTR16(IBOGID,ICDUAL,IPLSTM)
  390.             CALL ECROBJ('LISTMOTS',IPLSTM)
  391.             RETURN
  392.  
  393. *        ====================================
  394. *        MOT-CLE "CONT" => APPUIS UNILATERAUX
  395. *        ====================================
  396.          ELSEIF(IRET.EQ.5) THEN
  397.             MRIGID=IBOGID
  398.             SEGACT MRIGID
  399.             ISOPE= ISUPEQ
  400.             IF(ISUPEQ.EQ.0)  CALL CRTABL(ISOPE)
  401.             MTABLE=ISOPE
  402.             SEGDES MTABLE
  403.             CALL ECROBJ('TABLE   ',ISOPE)
  404.             RETURN
  405.  
  406. *        ==============================================================
  407. *        MOTS-CLES "SYME" OU "ANTI" => SOUS-MATRICES (ANTI-)SYMETRIQUES
  408. *        ==============================================================
  409.          ELSEIF (IRET.EQ.3 .OR. IRET.EQ.4) THEN
  410.             CALL EXTR13(IBOGID,IRET)
  411.             RETURN
  412.          ENDIF
  413.  
  414.  
  415. *        =============================================================
  416. *        MOTS-CLES "MAIL" OU "RIGI" => SOUS-MAILLAGES OU SOUS-MATRICES
  417. *        =============================================================
  418.          ICO=0
  419.          IMO=3
  420.          IF(IRET.EQ.2) THEN
  421.             ICO=1
  422.             IMO=2
  423.          ENDIF
  424.          CALL LIRMOT(NOMU,IMO,IMUL,ICO)
  425.          IF(IERR.NE.0) RETURN
  426.  
  427. *        ************************************************
  428. *        MATRICE AVEC SEULEMENT LES MULT. DE LAGRANGE OU
  429. *                AVEC TOUT SAUF LES MULT. DE LAGRANGE
  430. *        ************************************************
  431.          IF (IRET.EQ.2) THEN
  432.             CALL SEPA(IBOGID,IMUL)
  433.             CALL ECROBJ('RIGIDITE',IBOGID)
  434.             RETURN
  435.          ENDIF
  436.  
  437. *        ********************************************************
  438. *        MAILLAGE PARTIEL
  439. *          "NOMU" => TOUT SAUF LES MULT. DE LAGRANGE
  440. *          "MULT" => TOUS LES MULT. DE LAGRANGE
  441. *          "UNIL" => SEULEMENT LES MULT. ASSOCIES AUX COND. UNIL.
  442. *        ********************************************************
  443.          IF (IMUL.NE.0) THEN
  444.             CALL POIRIG(IBOGID,IMUL)
  445.             RETURN
  446.          ENDIF
  447.  
  448. *        ****************
  449. *        MAILLAGE COMPLET
  450. *        ****************
  451.          IF (IERR.NE.0) RETURN
  452.          CALL MELRIG(IBOGID,IPP1)
  453.          CALL ACTOBJ('MAILLAGE',IPP1,1)
  454.          CALL ECROBJ('MAILLAGE',IPP1)
  455.          RETURN
  456.  
  457.  
  458. * +-------------------------------------------------------------------+
  459. * |                                                                   |
  460. * |                     C   H   P   O   I   N   T                     |
  461. * |                                                                   |
  462. * +-------------------------------------------------------------------+
  463.       ELSEIF (CTYP.EQ.'CHPOINT') THEN
  464.          CALL LIROBJ('CHPOINT ',IBOPOI,1,IRETOU)
  465.          IF (IERR.NE.0) RETURN
  466.          CALL ACTOBJ('CHPOINT ',IBOPOI,1)
  467.          IF (IERR.NE.0) RETURN
  468.          CALL LIRCHA(CMOT,1,IRETOU)
  469.          IF (IERR.NE.0) RETURN
  470.          MOT_4=CMOT
  471.  
  472. *        =====================================
  473. *        MOT-CLE "TITR" => EXTRACTION DU TITRE
  474. *        =====================================
  475.          IF (MOT_4.EQ.'TITR') THEN
  476.             MCHPOI = IBOPOI
  477.             CTEXT = MOCHDE
  478.             ILON = LEN(CTEXT)
  479.             DO 100 I = ILON,1,-1
  480.                IF (CTEXT(I:I).NE.' ') THEN
  481.                   NLON = I
  482.                   GOTO 102
  483.                ENDIF
  484.  100        CONTINUE
  485.             NLON = 1
  486.  102        CONTINUE
  487.             CALL ECRCHA(CTEXT(1:NLON))
  488.             RETURN
  489.  
  490. *        =========================================
  491. *        MOT-CLE "NATU" => EXTRACTION DE LA NATURE
  492. *        =========================================
  493.          ELSEIF (MOT_4.EQ.'NATU') THEN
  494.             MCHPOI = IBOPOI
  495.             INAT = JATTRI(1)
  496.             IF (INAT.EQ.0) CTEXT(1:11) = 'INDETERMINE'
  497.             IF (INAT.EQ.1) CTEXT(1:11) = 'DIFFUS     '
  498.             IF (INAT.EQ.2) CTEXT(1:11) = 'DISCRET    '
  499.             CALL ECRCHA(CTEXT(1:11))
  500.             RETURN
  501.  
  502. *        ===================================================
  503. *        MOT-CLE "MAIL" => EXTRACTION DU SUPPORT GEOMETRIQUE
  504. *        ===================================================
  505.          ELSEIF (MOT_4 .EQ.'MAIL') THEN
  506.             IMUL=0
  507.             CALL LIRMOT(NOMU,1,IMUL,0)
  508.             IF (IERR.NE.0) RETURN
  509.             CALL EXTR21(IBOPOI,IMUL,IPP1)
  510.             IF (IERR.NE.0) RETURN
  511.             CALL ACTOBJ('MAILLAGE',IPP1,1)
  512.             CALL ECROBJ('MAILLAGE',IPP1)
  513.             RETURN
  514.  
  515. *        ========================================================
  516. *        MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES
  517. *        ========================================================
  518.          ELSEIF (MOT_4 .EQ.'COMP') THEN
  519.             CALL EXTR11(IBOPOI,KLISTM)
  520.             CALL ECROBJ('LISTMOTS',KLISTM)
  521.             RETURN
  522.  
  523. *        ====================================
  524. *        MOT-CLE "TYPE" => EXTRACTION DU TYPE
  525. *        ====================================
  526.          ELSEIF (MOT_4.EQ.'TYPE') THEN
  527.             MCHPOI = IBOPOI
  528.             MOT_8 = MTYPOI
  529.             CALL ECRCHA(MOT_8(1:8))
  530.             RETURN
  531.  
  532. *        ============================================================
  533. *        MOT-CLE "VALE" => EXTRACTION DES VALEURS EN PLUSIEURS POINTS
  534. *                          ET POUR PLUSIEURS COMPOSANTES
  535. *        ============================================================
  536.          ELSEIF (MOT_4.EQ.'VALE') THEN
  537. *
  538. *           LISTE DES COMPOSANTES (OBJET MOT OU LISTMOTS)
  539.             CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  540.             IF (IRETOU.EQ.1) THEN
  541.               SEGACT,MLMOTS
  542.  
  543.             ELSE
  544.                CALL LIRCHA(MOCOMP,0,IRETOU)
  545.                IF (IRETOU.GT.0) THEN
  546.                   JGN=LOCOMP
  547.                   JGM=1
  548.                   SEGINI,MLMOTS
  549.                   MOTS(1)=MOCOMP
  550.                   SEGACT,MLMOTS
  551.                ENDIF
  552.             ENDIF
  553. *
  554. *           LISTE DES NOEUDS (OBJET POINT OU MAILLAGE DE POI1)
  555.             CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  556.             IF (IRETOU.EQ.1) THEN
  557.               CALL ACTOBJ('MAILLAGE',MELEME,1)
  558.             ELSE
  559.                CALL LIROBJ('POINT',IPOINT,0,IRETOU)
  560.                IF (IRETOU.NE.0) THEN
  561.                   CALL CRELEM(IPOINT)
  562.                   MELEME=IPOINT
  563.                ENDIF
  564.             ENDIF
  565. *
  566. *           MOT-CLE 'NOID'
  567.             IVID=0
  568.             CALL LIRCHA(MOT_4,0,IRETOU)
  569.             IF (IRETOU.NE.0) THEN
  570.                IF (MOT_4.EQ.'NOID') THEN
  571.                   IVID=1
  572.                ELSE
  573.                   MOTERR(1:4)=MOT_4
  574.                   MOTERR(5:40)='NOID'
  575.                   CALL ERREUR(1052)
  576.                   RETURN
  577.                ENDIF
  578.             ENDIF
  579. *
  580. *           APPEL A EXTR23
  581.             CALL EXTR23(IBOPOI,MLMOTS,MELEME,MLREEL,IVID)
  582.             IF (IERR.NE.0) RETURN
  583.             SEGACT,MLREEL
  584.             CALL ECROBJ('LISTREEL',MLREEL)
  585.             RETURN
  586.  
  587. *        ===========================================================
  588. *        PAS DE MOT CLE : CMOT = NOM DE COMPOSANTE
  589. *        EXTRACTION DE LA VALEUR EN UN POINT D'UNE COMPOSANTE DONNEE
  590. *        ===========================================================
  591.          ELSE
  592.              CALL LIROBJ('POINT   ',MPOINT,1,IRETOU)
  593.              IF (IRETOU.EQ.0) THEN
  594.                  MOTERR(1:8)='POINT'
  595.                  CALL ERREUR(37)
  596.                  RETURN
  597.              ENDIF
  598. c            lecture facultative de l'harmonique de Fourier
  599.              CALL LIRENT(NHARM,0,IRET)
  600.              ZHARM=IRET.EQ.1
  601.              CALL EXTRA9(IBOPOI,MPOINT,CMOT,NHARM,ZHARM,XFLOT,IRET)
  602.              CALL ECRREE(XFLOT)
  603.              RETURN
  604.          ENDIF
  605.  
  606.  
  607.  
  608. * +-------------------------------------------------------------------+
  609. * |                                                                   |
  610. * |                       M   C   H   A   M   L                       |
  611. * |                                                                   |
  612. * +-------------------------------------------------------------------+
  613.       ELSEIF (CTYP.EQ.'MCHAML') THEN
  614.          CALL LIROBJ('MCHAML  ',IPCHE1,1,IRET)
  615.          IF (IERR.NE.0) RETURN
  616. C
  617.          CALL LIRCHA(CMOT,1,IRET0)
  618.          IF (IERR.NE.0) RETURN
  619.          MOT_4=CMOT
  620.          ICOD=1
  621.          IF (MOT_4.EQ.'CONF') ICOD=2
  622.  
  623.          CALL ACTOBJ('MCHAML  ',IPCHE1,ICOD)
  624.  
  625. *        ================================================
  626. *        MOTS-CLES "CONF" CONFIGURATION DU CHAMP
  627. *        ================================================
  628.          IF (MOT_4.EQ.'CONF') THEN
  629.             mchelm=ipche1
  630.             segact mchelm
  631.               mcnf=mclcnf
  632.               if (mcnf.eq.0) mcnf=mcoord
  633.               CALL ECROBJ('CONFIGUR',mcnf)
  634.             RETURN
  635.  
  636. *        ================================================
  637. *        MOTS-CLES "DEVA" OU "COVA" => NOMS DES VARIABLES
  638. *        ================================================
  639.          ELSEIF (MOT_4.EQ.'DEVA' .OR. MOT_4.EQ.'COVA') THEN
  640.             CALL EXCHA1(IPCHE1,ILISR,MOT_4)
  641.             IF (ILISR.NE.0) THEN
  642.               CALL ACTOBJ('LISTMOTS',ILISR,1)
  643.               CALL ECROBJ('LISTMOTS',ILISR)
  644.             ENDIF
  645.             RETURN
  646.  
  647. *        =================================
  648. *        MOT-CLE "NBZO" => NOMBRE DE ZONES
  649. *        =================================
  650.          ELSEIF (MOT_4.EQ.'NBZO') THEN
  651.             CALL EXTR18(IPCHE1,NBZONE)
  652.             if (ierr.ne.0) return
  653.             CALL ECRENT(NBZONE)
  654.             RETURN
  655.  
  656. *        =====================================================
  657. *        MOT-CLE "COMP" => EXTRACTION DES NOMS DES COMPOSANTES
  658. *        =====================================================
  659.          ELSEIF (MOT_4.EQ.'COMP' ) THEN
  660.             CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  661. C
  662. C           RECHERCHE DES NOMS DES COMPOSANTES APPARTENANT
  663. C           A LA ZONE DU MODELE
  664.             IF (IRETM.NE.0) THEN
  665.                CALL ACTOBJ('MMODEL',IPMODL,1)
  666.                CALL EXTR15(IPMODL,IPCHE1,IPLSTM)
  667.                IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  668.                RETURN
  669. C
  670. C           RECHERCHE DES NOMS DE TOUTES LES COMPOSANTES
  671.             ELSE
  672.                CALL EXTR17(IPCHE1,IPLSTM)
  673.                CALL ECROBJ('LISTMOTS',IPLSTM)
  674.                RETURN
  675.             ENDIF
  676.  
  677. *        ======================================================
  678. *        MOT-CLE "CONS" => EXTRACTION DES NOMS DES CONSTITUANTS
  679. *        ======================================================
  680.          ELSEIF(MOT_4.EQ.'CONS' ) THEN
  681.             CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
  682. C
  683. C           RECHERCHE DES NOMS DES CONSTITUANTS APPARTENANT
  684. C           A LA ZONE DU MODELE
  685.             IF (IRETM.NE.0) THEN
  686.                CALL ACTOBJ('MMODEL',IPMODL,1)
  687.                CALL EXTR35(IPMODL,IPCHE1,IPLSTM)
  688.                IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
  689.                RETURN
  690. C
  691. C           RECHERCHE DES NOMS DE TOUs LES constituants
  692.             ELSE
  693.                CALL EXTR37(IPCHE1,IPLSTM)
  694.                CALL ECROBJ('LISTMOTS',IPLSTM)
  695.                RETURN
  696.             ENDIF
  697.  
  698. *        ==================================================
  699. *        MOT-CLE "VALE" => EXTRACTION DE TOUTES LES VALEURS
  700. *        ==================================================
  701.          ELSEIF(MOT_4.EQ.'VALE' ) THEN
  702.             CALL LIRCHA(CMOT,1,IRET0)
  703.             IF (IERR.NE.0) RETURN
  704.             CALL EXTR25(IPCHE1,CMOT,ILIST,IRET)
  705.             IF (IRET.EQ.0) THEN
  706.                CALL ECROBJ('LISTREEL',ILIST)
  707.             ELSE
  708.                CALL ECROBJ('LISTENTI',ILIST)
  709.             ENDIF
  710.             RETURN
  711.  
  712. *        =========================================================
  713. *        EXTRACTION D'UNE VALEUR, DU TITRE, DU TYPE OU DU MAILLAGE
  714. *        =========================================================
  715.          ELSE
  716.             IF (MOT_4.NE.'TITR'.AND.MOT_4.NE.'TYPE'.AND.
  717.      &          MOT_4.NE.'MAIL') THEN
  718.                IENT1 = 0
  719.                IENT2 = 0
  720.                IENT3 = 0
  721.                IPMAIL = 0
  722.                CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET0)
  723.                IF (IRET0.NE.0) THEN
  724.                  CALL ACTOBJ('MAILLAGE',IPMAIL,1)
  725.                  IF (IERR.NE.0) RETURN
  726.                  MELEME = IPMAIL
  727.                  NBEL1 = NUM(/2)
  728.                  IF (NBEL1.NE.1) THEN
  729.                    CALL ERREUR(426)
  730.                    RETURN
  731.                  ENDIF
  732.                  IENT3 = 0
  733.                  CALL LIRENT(IENT3,0,IRET3)
  734.                  IF (IRET3.NE.0.AND.IENT3.LE.0) THEN
  735.                    INTERR(1) = IENT3
  736.                    CALL ERREUR(36)
  737.                    RETURN
  738.                  ENDIF
  739.                ELSE
  740.                  IPMAIL = 0
  741.                  CALL LIRENT(IENT1,1,IRET1)
  742.                  IF(IRET1.EQ.0) RETURN
  743.                  IF (IENT1.LE.0) THEN
  744.                    INTERR(1) = IENT1
  745.                    CALL ERREUR(36)
  746.                    RETURN
  747.                  ENDIF
  748.                  CALL LIRENT(IENT2,1,IRET2)
  749.                  IF(IRET2.EQ.0) RETURN
  750.                  IF (IENT2.LE.0) THEN
  751.                    INTERR(1) = IENT2
  752.                    CALL ERREUR(36)
  753.                    RETURN
  754.                  ENDIF
  755.                  CALL LIRENT(IENT3,1,IRET3)
  756.                  IF(IRET3.EQ.0) RETURN
  757.                  IF (IENT3.LE.0) THEN
  758.                    INTERR(1) = IENT3
  759.                    CALL ERREUR(36)
  760.                    RETURN
  761.                  ENDIF
  762.                ENDIF
  763.             ENDIF
  764.             CALL EXTR14(IPCHE1,IENT1,IENT2,IENT3,CMOT,IPMAIL)
  765.             RETURN
  766.          ENDIF
  767.  
  768.  
  769. * +-------------------------------------------------------------------+
  770. * |                                                                   |
  771. * |                       M   M   O   D   E   L                       |
  772. * |                                                                   |
  773. * +-------------------------------------------------------------------+
  774.       ELSEIF (CTYP.EQ.'MMODEL') THEN
  775.          CALL LIROBJ('MMODEL',IPMODL,1,IRET)
  776.          CALL ACTOBJ('MMODEL',IPMODL,1)
  777.          IF (IERR.NE.0) RETURN
  778.          CALL LIRMOT(CMOC,NBCMOC,IRET,1)
  779.          IF(IERR.NE.0) RETURN
  780.          CMOT  =CMOC(IRET)
  781.          MOT_4 =CMOT
  782.  
  783. C        Extension du MMODEL en cas de modele de MELANGE
  784.          CALL MODETE(IPMODL,MMODEL,IMELAN)
  785.          NSOUS=MMODEL.KMODEL(/1)
  786.  
  787. C=DEB==== FORMULATION HHO ==== Cas particulier =========================
  788.          IF (MOT_4.EQ.'HHO_') THEN
  789.            CALL REFUS
  790.            CALL LIRCHA(CTEXT,1,iret)
  791.            IF (IERR.NE.0) RETURN
  792.            CALL HHOEXT(IPMODL,CTEXT, IPP1,CTYP,iret)
  793.            IF (iret.NE.0) THEN
  794.              CALL ERREUR(iret)
  795.              RETURN
  796.            END IF
  797.            IF (IPP1.LE.0) THEN
  798.              CALL ERREUR(21)
  799.              RETURN
  800.            END IF
  801.            CALL ACTOBJ(CTYP,IPP1,1)
  802.            CALL ECROBJ(CTYP,IPP1)
  803.            RETURN
  804.          END IF
  805. C=FIN==== FORMULATION HHO ==============================================
  806.  
  807.          IF (MOT_4.EQ.'MAIL') THEN
  808.             IMFRO=.FALSE.
  809.             CALL LIRMOT(CFROT,1,IRET,0)
  810.             IF (IRET.EQ.1) THEN
  811.               IMFRO=.TRUE.
  812.             ENDIF
  813.               IPP1=0
  814.                   ltelq=.false.
  815.                 DO 1116 I=1,NSOUS
  816.                   IMODEL= KMODEL(I)
  817.                  IF (IMFRO) THEN
  818.                   NMATT=MATMOD(/2)
  819.                   CALL PLACE(MATMOD,NMATT,IPLAC,'FROTTANT')
  820.                   if(iplac.eq.0) goto 1116
  821.                  ENDIF
  822.                   IPP2  = IMAMOD
  823.                   IF (ipp1.eq.0) then
  824.                     ipp1=ipp2
  825.                   ELSE
  826.                     CALL FUSE (IPP1,IPP2,IRET,ltelq)
  827.                     IPP1=IRET
  828.                   ENDIF
  829.  1116           CONTINUE
  830.  
  831.             IF(IPP1.EQ.0) THEN
  832. C             Cas du resultat vide ==> MAILLAGE VIDE
  833.               NBELEM = 0
  834.               NBNN   = NBNNE(ILCOUR)
  835.               NBREF  = 0
  836.               NBSOUS = 0
  837.               SEGINI,MELEME
  838.               ITYPEL = ILCOUR
  839.               IPP1   = MELEME
  840.             ENDIF
  841.             CALL ACTOBJ('MAILLAGE',IPP1,1)
  842.             CALL ECROBJ('MAILLAGE',IPP1)
  843.             RETURN
  844.  
  845.          ELSEIF (MOT_4.eq.'COMP') THEN
  846.             CALL LIRCHA(MOFORM(1),1,iretou)
  847.             if(ierr.ne.0) return
  848.             N1=0
  849.             SEGINI,MMODE1
  850.             DO 5497 I=1,NSOUS
  851.               IMODEL=KMODEL(I)
  852.               DO IB=1,MATMOD(/2)
  853.                 IF( MATMOD(IB) .EQ. MOFORM(1) ) GOTO 5498
  854.               ENDDO
  855.               GOTO 5497
  856.  5498         CONTINUE
  857.               N1=N1+1
  858.               MMODE1.KMODEL(**)=KMODEL(I)
  859.  5497       CONTINUE
  860.  
  861.             IF(N1.GE.0.AND.N1.LT.NSOUS) THEN
  862.               SEGADJ,MMODE1
  863.  
  864.             ELSEIF(N1.EQ.NSOUS)THEN
  865. C             Pas la peine de creer un autre MMODEL
  866.               SEGSUP,MMODE1
  867.               MMODE1=MMODEL
  868.  
  869.             ELSE
  870.               CALL ERREUR(5)
  871.             ENDIF
  872.  
  873.             CALL ACTOBJ('MMODEL  ',MMODE1,1)
  874.             CALL ECROBJ('MMODEL  ',MMODE1)
  875.             RETURN
  876.  
  877.          ELSEIF(MOT_4.EQ.'OBJE') THEN
  878.             if(NSOUS.ne.1) then
  879.                WRITE(IOIMP,*) ' Dans extrai.eso : '
  880.                WRITE(IOIMP,*) ' ce n est pas un modele elementaire'
  881.                WRITE(IOIMP,*) ' it is not an elementary model'
  882.                call erreur(19)
  883.                return
  884.             endif
  885.             imodel=kmodel(1)
  886.             iob=ivamod(/1)
  887.             do io=iob,1,-1
  888.                ctyp=tymode(io)
  889.                if( ctyp.eq.'ENTIER') then
  890.                   call ecrent(ivamod(io))
  891.                else
  892.                   ipoin1=ivamod(io)
  893.                   call ecrobj(ctyp,ipoin1)
  894.                endif
  895.             enddo
  896.             return
  897.  
  898.          ELSEIF (MOT_4.EQ.'ZONE') THEN
  899. C- Option 'ZONE' 'CONS' => IZOCO=1
  900.             IZOCO = 0
  901.             CALL LIRMOT(CMOC(4),1,IZOCO,0)
  902.             IF (IERR.NE.0) RETURN
  903.  
  904.             INCTS = 2
  905.             IF (IZOCO.EQ.1) INCTS = 3
  906.             M = INCTS * NSOUS
  907.             N1 = 1
  908.             SEGINI MTABLE
  909.  
  910.             DO IOK=1,NSOUS
  911.               IMODEL=KMODEL(IOK)
  912.               NFOR=FORMOD(/2)
  913. C      CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  914.               CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  915.               CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  916.               CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  917.               IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  918.                 SEGINI,IMODE1=IMODEL
  919.                 IMODE1.INFMOD(2)=0
  920.                 IMODEL=IMODE1
  921.               ENDIF
  922.               SEGINI MMODE1
  923.               MMODE1.KMODEL(1) = IMODEL
  924.               IVALI1 = (IOK-1)*INCTS + 1
  925.               IPP1   = MMODE1
  926.               CALL ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
  927.      $                 IOBIN,'MMODEL  ',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  928.               IVALI1 = IVALI1 + 1
  929.               IPP1   = IMAMOD
  930.               CALL ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
  931.      $                 IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP1)
  932.               IF (IZOCO.EQ.1) THEN
  933.                 IVALI1 = IVALI1 + 1
  934.                 MOT_CM = CONMOD
  935.                 CALL ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
  936.      $                   IOBIN,'MOT     ',IVALRE,XFLOT,MOT_CM,LAG,IPP1)
  937.               ENDIF
  938. C              SEGDES IMODEL
  939.             ENDDO
  940.  
  941.             CALL ECROBJ('TABLE   ',MTABLE)
  942.             RETURN
  943.  
  944.          ELSEIF (MOT_4.EQ.'FORM'.OR.MOT_4.EQ.'CONS'.OR.MOT_4.EQ.'ELEM'
  945.      &    .OR. MOT_4.EQ.'MATE'.OR.MOT_4.EQ.'NON_'
  946.      &    .OR.MOT_4.EQ.'PHAS') THEN
  947.             INFOR=1
  948.             IF (MOT_4.EQ.'MATE'.OR.MOT_4.EQ.'PHAS') THEN
  949.                IPASS=0
  950.                ICOND=0
  951.  1191          CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  952.                IF (IERR.NE.0) RETURN
  953.                IPASS=IPASS+1
  954.                IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN
  955.                   CALL NOVARD(MMODEL,MOT_4)
  956.                   RETURN
  957.                ENDIF
  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 1191
  965.                ENDIF
  966.             ELSE
  967.                ICOND=1
  968.  1192          CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
  969.                IF (IERR.NE.0) RETURN
  970.                ICOND=0
  971.                IF (IRETO.NE.0) THEN
  972.                   INFOR=INFOR+1
  973.                   IF (INFOR.GT.NBFORM) THEN
  974.                      CALL ERREUR(5)
  975.                      RETURN
  976.                   ENDIF
  977.                   GOTO 1192
  978.                ENDIF
  979.             ENDIF
  980.             INFOR=INFOR-1
  981. C
  982.             JGN=4
  983.             JGM=0
  984.             SEGINI MLMOTS
  985.             MLNONL=MLMOTS
  986. C
  987.             MMODE1=MMODEL
  988.  
  989.             IF (NSOUS .EQ. 0) THEN
  990. C             TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  991. C             partie
  992.               CALL ECROBJ('MMODEL  ',IPMODL)
  993.               RETURN
  994.  
  995.             ELSE
  996.               N1=NSOUS
  997.               SEGINI,MMODEL
  998.               IPP1=MMODEL
  999.               NZON=0
  1000.               IMECAF=0
  1001.               DO 1119 I=1,NSOUS
  1002.                  IMODEL=MMODE1.KMODEL(I)
  1003.                  IF(MOT_4.EQ.'FORM') THEN
  1004.                     NFOR=FORMOD(/2)
  1005.  
  1006.                     IF(NFOR.NE.INFOR) GOTO 1119
  1007.                     IF(NFOR.EQ.1) THEN
  1008.                        IF(MOFORM(1).NE.FORMOD(1)) GOTO 1119
  1009.                     ELSEIF(NFOR.EQ.2) THEN
  1010.                        IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE.
  1011.      $                    FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND.
  1012.      $                    (MOFORM(2).NE.FORMOD(1))))GOTO 1119
  1013.                     ELSE
  1014.                        GOTO 1118
  1015.                     ENDIF
  1016.                  ELSEIF (MOT_4.EQ.'CONS') THEN
  1017.                      DO 425 IJ=1,INFOR
  1018. C                    on enleve les espaces au debut et a la fin
  1019.                        idim0=LEN(MOFORM(IJ))
  1020.                        idim1=CONMOD(/1)
  1021.                        ideb0=0
  1022.                        ifin0=0
  1023.                        ideb1=0
  1024.                        ifin1=0
  1025.                        DO ii=1,idim0
  1026.                          IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ')
  1027.      $                         ideb0=ii
  1028.                           IF(ifin0.EQ.0.AND.
  1029.      &                        MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ')
  1030.      &                        ifin0=idim0-ii+1
  1031.                       ENDDO
  1032.                       DO ii=1,idim1
  1033.                         IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii
  1034.                         IF(ifin1.EQ.0.AND.
  1035.      &                         CONMOD(idim1-ii+1:idim1-ii+1).NE.' ')
  1036.      &                         ifin1=idim1-ii+1
  1037.                        ENDDO
  1038. C                    print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1
  1039.                       IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1))
  1040.      &                     GOTO 429
  1041.  425                 CONTINUE
  1042.                    GOTO 1119
  1043.                  ELSEIF (MOT_4.EQ.'ELEM') THEN
  1044.                     DO 426 IJ=1,INFOR
  1045.                        IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GOTO 429
  1046.  426                CONTINUE
  1047.                     GOTO 1119
  1048.                  ELSEIF(MOT_4.EQ.'MATE') THEN
  1049.                     NMAT=MATMOD(/2)
  1050.                     DO 427 IJ=1,INFOR
  1051.                        DO 4275 JJ=1,NMAT
  1052.                          IF(MATMOD(JJ).EQ.MOFORM(IJ)) GOTO 429
  1053.  4275                  CONTINUE
  1054.  427                CONTINUE
  1055.                    GOTO 1119
  1056.                  ELSEIF(MOT_4.EQ.'NON_') THEN
  1057.                     MN3=INFMOD(/1)
  1058.                     IF(MN3.LE.12) GOTO 1119
  1059.                     INLOC=-1*INFMOD(13)
  1060.                     IF(INLOC.EQ.0) GOTO 1119
  1061.                     CALL MODNLO(MNLOCA,NLODIM)
  1062.                     DO 428 IJ=1,INFOR
  1063.                       IF(MNLOCA(INLOC).EQ.MOFORM(IJ)(1:4)) GOTO 429
  1064.  428                CONTINUE
  1065.                    GOTO 1119
  1066.                  ELSEIF(MOT_4.EQ.'PHAS'
  1067.      &                  .AND.CONMOD.NE.'                ') THEN
  1068.                         DO 430 IJ=1,INFOR
  1069.                         IF(CONMOD(17:24).EQ.MOFORM(IJ)(1:8)) GOTO 429
  1070. 430             CONTINUE
  1071.                     GOTO 1119
  1072.                  ENDIF
  1073. C     on vient ici pour prendre les sous modeles
  1074.  429             CONTINUE
  1075.                  NZON=NZON+1
  1076.                  NFOR=FORMOD(/2)
  1077.  
  1078. C                CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  1079.                  CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  1080.                  CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  1081.                  CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  1082.                  IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
  1083.                     IMECAF=1
  1084.                     SEGINI,IMODE1=IMODEL
  1085.                     IMODE1.INFMOD(2)=0
  1086.                     IMODEL=IMODE1
  1087.                  ENDIF
  1088.  
  1089.                  KMODEL(NZON)=IMODEL
  1090.  1119        CONTINUE
  1091.             ENDIF
  1092. C
  1093.             IF(NZON.EQ.0) GOTO 1118
  1094.  
  1095.             IF(NZON.EQ.NSOUS .AND. IMECAF.EQ.0) THEN
  1096. C             Le SOUS-MODELE demande est le MODELE d'origine
  1097.               CALL ECROBJ('MMODEL  ',IPMODL)
  1098.  
  1099.             ELSE
  1100.               IF(NZON.NE.NSOUS)THEN
  1101.                 N1=NZON
  1102.                 SEGADJ,MMODEL
  1103.               ENDIF
  1104.               CALL ACTOBJ('MMODEL  ',IPP1,1)
  1105.               CALL ECROBJ('MMODEL  ',IPP1)
  1106.             ENDIF
  1107.             RETURN
  1108.  
  1109.  1118       CONTINUE
  1110.             CALL ERREUR(610)
  1111.             RETURN
  1112.  
  1113.          ELSEIF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN
  1114.             CALL NOVARD(MMODEL,MOT_4)
  1115.             RETURN
  1116.  
  1117.          ELSEIF (IRET.EQ.22) THEN
  1118.            JGN=4
  1119.            JGM=0
  1120.            SEGINI MLMOTS
  1121.            MLNONL=MLMOTS
  1122. C
  1123.            MMODE1=MMODEL
  1124.            NSOUS=MMODE1.KMODEL(/1)
  1125. C
  1126. C           TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous
  1127. C           partie
  1128.             IF (NSOUS .EQ. 0) THEN
  1129.               SEGACT,MLMOTS
  1130.               CALL ECROBJ('LISTMOTS',MLMOTS)
  1131.               RETURN
  1132.             ELSE
  1133.               DO 1122 I=1,NSOUS
  1134.                  IMODEL=MMODE1.KMODEL(I)
  1135.                  NFOR=FORMOD(/2)
  1136.                  IF(NFOR.GE.1) THEN
  1137.                     IF (FORMOD(1).NE.'MECANIQUE'.AND.
  1138.      &                  FORMOD(1).NE.'POREUX') GOTO 1123
  1139.                     MN3=INFMOD(/1)
  1140.                     IF(MN3.LE.12) GOTO 1123
  1141.                     INONL=INFMOD(14)
  1142.                     IF(INONL.EQ.0) GOTO 1123
  1143.                     MLMOT1=INONL
  1144.                     SEGACT MLMOT1
  1145.                     NMONL=MLMOT1.MOTS(/2)
  1146.                     IF(NMONL.EQ.0)GOTO 1123
  1147.                     IF(JGM.EQ.0) THEN
  1148.                       JGM=NMONL
  1149.                       SEGADJ,MLMOTS
  1150.                       DO IJ=1,NMONL
  1151.                         MOTS(IJ)=MLMOT1.MOTS(IJ)
  1152.                       ENDDO
  1153.                     ELSE
  1154.                       DO IJ=1,NMONL
  1155.                         CALL PLACE(MOTS,JGM,IPLA,MLMOT1.MOTS(IJ))
  1156.                         IF(IPLA.EQ.0) THEN
  1157.                           JGM=JGM+1
  1158.                           SEGADJ,MLMOTS
  1159.                           MOTS(JGM)=MLMOT1.MOTS(IPLA)
  1160.                         ENDIF
  1161.                       ENDDO
  1162.                     ENDIF
  1163. 1123                CONTINUE
  1164.                  ENDIF
  1165. 1122          CONTINUE
  1166.               SEGACT,MLMOTS
  1167.               CALL ECROBJ('LISTMOTS',MLMOTS)
  1168.               RETURN
  1169.             ENDIF
  1170. *
  1171.          ELSE IF (MOT_4.eq.'CENT') THEN
  1172. * pour NAVIER-STOKE NLIN, extrai les POINTS CENTRES
  1173.            ipma = 0
  1174. c
  1175.            L1 = 8
  1176.            n1 = 1
  1177.            segini mmode1
  1178.            n3 = 6
  1179.            segini mchel1
  1180.            n2 = 1
  1181.            segini mcham1
  1182.            mchel1.ichaml(1) = mcham1
  1183.            ipmons = mmode1
  1184.            ipchns = mchel1
  1185.            do is = 1,nsous
  1186.              imodel = kmodel(is)
  1187.              if (formod(1).eq.'NAVIER_STOKES'.and.matmod(1).eq.'NLIN')
  1188.      & then
  1189.                mmode1.kmodel(1) = imodel
  1190.                call go2nli(ipmons,ipchns,ipres,5)
  1191.                if (ierr.ne.0 ) return
  1192.              endif
  1193.              if (ipma.eq.0) then
  1194.                ipma = ipres
  1195.              else
  1196.                call fuse(ipma,ipres,ip3,.true.)
  1197.                if (ierr.ne.0) return
  1198.                ipma = ip3
  1199.              endif
  1200.            enddo
  1201.            segsup mchel1, mcham1, mmode1
  1202.            if (IPMA.GT.0) then
  1203.              call ecrobj('MAILLAGE',ipma)
  1204.              return
  1205.            else
  1206.              call erreur(21)
  1207.              return
  1208.            endif
  1209.          ELSE
  1210.             MOTERR=MOT_4
  1211.             CALL ERREUR(7)
  1212.             RETURN
  1213.          ENDIF
  1214.  
  1215.  
  1216. * +-------------------------------------------------------------------+
  1217. * |                                                                   |
  1218. * |               C   H   A   R   G   E   M   E   N   T               |
  1219. * |                                                                   |
  1220. * +-------------------------------------------------------------------+
  1221.       ELSEIF (CTYP.EQ.'CHARGEME') THEN
  1222.          CALL LIROBJ('CHARGEME',ICHAR,1,IRET)
  1223.          IF (IERR.NE.0) RETURN
  1224. C
  1225.          CMOT  = '    '
  1226.          ICHGT = 0
  1227.          LCHGT = 0
  1228.          IEC   = 1
  1229.          CALL LIROBJ('LISTMOTS',LCHGT,0,IRET)
  1230.          IF (IERR.NE.0) RETURN
  1231.          IF (IRET.EQ.0) THEN
  1232.             CALL LIRCHA(CMOT,1,IRETOU)
  1233.             IF (IERR.NE.0) RETURN
  1234.             CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT)
  1235.             IF ((ICHGT.GE.1 .AND. ICHGT.LE.5) .OR. ICHGT.GE.9) THEN
  1236.                CALL LIRENT(IEC,0,IRETOU)
  1237.                IF (IERR.NE.0) RETURN
  1238.                IF (IRETOU.EQ.0) IEC = 1
  1239.             ELSEIF (ICHGT.EQ.0) THEN
  1240.                CALL LIRCHA(MOT_4,0,IRETOU)
  1241.                IF (IRETOU.NE.0) THEN
  1242.                   IF (MOT_4.EQ.'TABL') THEN
  1243.                      ICHGT=-1
  1244.                   ELSE
  1245.                      CALL REFUS
  1246.                   ENDIF
  1247.                ENDIF
  1248.             ENDIF
  1249.          ENDIF
  1250. C
  1251.          CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8)
  1252. C
  1253.          IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1)
  1254.          IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2)
  1255.          RETURN
  1256.  
  1257.  
  1258. * +-------------------------------------------------------------------+
  1259. * |                                                                   |
  1260. * |                   L   I   S   T   C   H   P   O                   |
  1261. * |                                                                   |
  1262. * +-------------------------------------------------------------------+
  1263.       ELSEIF (CTYP.EQ.'LISTCHPO') THEN
  1264.          CALL LIROBJ('LISTCHPO',ILCHP1,1,IRET)
  1265.          IF (IERR.NE.0) RETURN
  1266.          CALL QUETYP(CTYP1,0,IRETOU)
  1267.          IF (IRETOU.EQ.0) THEN
  1268.             CALL ERREUR(533)
  1269.             RETURN
  1270.          ENDIF
  1271.  
  1272.          MLCHP1 = ILCHP1
  1273.          SEGACT , MLCHP1
  1274.          LONCHP = MLCHP1.ICHPOI(/1)
  1275.  
  1276. *        ===============================
  1277. *        EXTRACTION DE PLUSIEURS INDICES
  1278. *        ===============================
  1279.          IF (CTYP1.EQ.'LISTENTI') THEN
  1280.             CALL LIROBJ('LISTENTI',ILENT,1,IRET)
  1281.             IF (IERR.NE.0) RETURN
  1282.             MLENTI = ILENT
  1283.             SEGACT,MLENTI
  1284.             JG = LECT(/1)
  1285.             N1=JG
  1286.             SEGINI,MLCHP2
  1287.             ILCHP2= MLCHP2
  1288.             DO 1211 I=1 , JG
  1289.                IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN
  1290.                   INTERR(1) = LECT(I)
  1291.                   CALL ERREUR(620)
  1292.                ENDIF
  1293.                MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I))
  1294.  1211       CONTINUE
  1295.             CALL ACTOBJ ('LISTCHPO',ILCHP2,0)
  1296.             CALL ECROBJ ('LISTCHPO',ILCHP2)
  1297.             RETURN
  1298.  
  1299. *        ===========================
  1300. *        EXTRACTION D'UN SEUL INDICE
  1301. *        ===========================
  1302.          ELSEIF (CTYP1.EQ.'ENTIER') THEN
  1303.             CALL LIRENT(ILENT,1,IRETOU)
  1304.             IF (IERR.NE.0) RETURN
  1305.             IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN
  1306.                INTERR(1)=ILENT
  1307.                CALL ERREUR(620)
  1308.             ENDIF
  1309.             ILCHPO = MLCHP1.ICHPOI(ILENT)
  1310.             CALL ACTOBJ('CHPOINT ',ILCHPO,1)
  1311.             CALL ECROBJ('CHPOINT ',ILCHPO)
  1312.             RETURN
  1313.  
  1314. *        ====================================================
  1315. *        MOT-CLE "VALE" => EXTRACTION DES VALEURS EN UN POINT
  1316. *        ====================================================
  1317.          ELSEIF (CTYP1.EQ.'MOT') THEN
  1318.             CALL LIRCHA(CMOT,1,IRETOU)
  1319.             IF (IERR.NE.0) RETURN
  1320.             IF (CMOT.NE.'VALE') THEN
  1321.                 MOTERR = 'VALE'
  1322.                 CALL ERREUR(396)
  1323.                 RETURN
  1324.             ENDIF
  1325.             CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  1326.             IF (IRETOU.EQ.0) THEN
  1327.                 CALL LIRCHA(MOCOMP,0,IRETOU)
  1328.                 IF (IRETOU.GT.0) THEN
  1329.                     JGN=LOCOMP
  1330.                     JGM=1
  1331.                     SEGINI,MLMOTS
  1332.                     MOTS(1)=MOCOMP
  1333.                 ENDIF
  1334.             ENDIF
  1335.             CALL LIROBJ('POINT',MPOINT,1,IRETOU)
  1336.             IF (IERR.NE.0) RETURN
  1337.             CALL EXTR24(MLCHP1,MLMOTS,MPOINT,MLREEL)
  1338.             IF (IERR.NE.0) RETURN
  1339.             SEGACT,MLREEL
  1340.             CALL ECROBJ('LISTREEL',MLREEL)
  1341.             RETURN
  1342.  
  1343. *        SYNTAXE INCORRECTE
  1344.          ELSE
  1345.             MOTERR(1:40) = 'ENTIER  LISTENTI"VALE"'
  1346.             CALL ERREUR(471)
  1347.             RETURN
  1348.          ENDIF
  1349.  
  1350.  
  1351. * +-------------------------------------------------------------------+
  1352. * |                                                                   |
  1353. * |                         N   U   A   G   E                         |
  1354. * |                                                                   |
  1355. * +-------------------------------------------------------------------+
  1356.       ELSEIF (CTYP.EQ.'NUAGE') THEN
  1357.          CALL LIROBJ('NUAGE   ',IPOINT,1,IRET)
  1358.          CALL ACTOBJ('NUAGE   ',IPOINT,1)
  1359.          IF (IERR.NE.0) RETURN
  1360.  
  1361.          MNUAGE=IPOINT
  1362.          CALL LIRMOT(NUMO,5,INU1,0)
  1363.          IF (INU1.EQ.0) THEN
  1364.             CALL LIRCHA(CTYP1,1,IRETOU)
  1365.             IF (IERR.NE.0) THEN
  1366.                RETURN
  1367.             ENDIF
  1368.             CALL LIRMOT(NUMO,5,INU1,0)
  1369.             IF (INU1.EQ.0) THEN
  1370.                IF (CTYP1.EQ.'COMP    ') THEN
  1371.                   IPROG = 1
  1372.                ELSE
  1373.                   IPOSI = 0
  1374.                   DO 1250 I=1,NUANOM(/2)
  1375.                      IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1376.  1250             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 = 2
  1384.                ENDIF
  1385.             ELSE
  1386.                IPOSI = 0
  1387.                DO 1251 I=1,NUANOM(/2)
  1388.                   IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1389.  1251          CONTINUE
  1390.                IF (IPOSI.EQ.0) THEN
  1391.                   MOTERR(1:8) = CTYP1
  1392. C                 TYP1 n'est pas un nom de variable du NUAGE
  1393.                   CALL ERREUR(672)
  1394.                   RETURN
  1395.                ENDIF
  1396.                IPROG = 3
  1397.             ENDIF
  1398.          ELSE
  1399.             CALL LIRCHA(CTYP1,1,IRETOU)
  1400.             IF (IERR.NE.0) RETURN
  1401.             IPOSI = 0
  1402.             DO 1252 I=1,NUANOM(/2)
  1403.                IF (NUANOM(I).EQ.CTYP1) IPOSI=I
  1404.  1252       CONTINUE
  1405.             IF (IPOSI.EQ.0) THEN
  1406.                MOTERR= CTYP1
  1407. C              TYP1 n'est pas un nom de variable du NUAGE
  1408.                CALL ERREUR(672)
  1409.                RETURN
  1410.             ELSE
  1411.                IPROG = 3
  1412.             ENDIF
  1413.          ENDIF
  1414.  
  1415. C-------------- Lecture eventuelle des FLOTTANTS -------------
  1416.          IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN
  1417.             IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN
  1418.                CALL LIRREE(XVAL1,0,IRETOU)
  1419.                IF (IRETOU.EQ.0) THEN
  1420. C                 Il manque la valeur de la composante reelle
  1421.                   CALL ERREUR(668)
  1422.                   RETURN
  1423.                ENDIF
  1424.             ELSE
  1425.                CALL LIRREE(XVAL1,0,IRETO1)
  1426.                CALL LIRREE(XVAL2,0,IRETO2)
  1427.                IF ((IRETO1.EQ.0).OR.(IRETO2.EQ.0)) THEN
  1428. C                 Il faut specifier deux valeurs reelles
  1429.                   CALL ERREUR(673)
  1430.                   RETURN
  1431.                ENDIF
  1432.             ENDIF
  1433.          ENDIF
  1434.  
  1435. C--------- Cas de l'extraction des noms des composantes du NUAGE -------
  1436.          IF (IPROG.EQ.1) THEN
  1437.             CALL EXTR19(IPOINT,IPLSTM)
  1438.             IF (IPLSTM.NE.0) THEN
  1439.                CALL ECROBJ('LISTMOTS',IPLSTM)
  1440.             ENDIF
  1441.  
  1442. C----Cas de l'extraction de l'objet correspondant a une composante ---
  1443. C----------------- donnee d'un NUAGE "colonne" -----------------------
  1444.  
  1445.          ELSEIF (IPROG.EQ.2) THEN
  1446.             CALL EXTR51(IPOINT,IPOSI)
  1447.  
  1448. C---------------------------- Autres cas ------------------------------
  1449.          ELSEIF (IPROG.EQ.3) THEN
  1450.             IF (INU1.EQ.1) THEN
  1451.                BORINF=.TRUE.
  1452.                CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1453.             ELSEIF (INU1.EQ.2) THEN
  1454.                BORINF=.FALSE.
  1455.                CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI)
  1456.             ELSEIF (INU1.EQ.3) THEN
  1457.                MINI =.TRUE.
  1458.                CALL EXTR52(IPOINT,MINI,IPOSI)
  1459.             ELSEIF (INU1.EQ.4) THEN
  1460.                MINI =.FALSE.
  1461.                CALL EXTR52(IPOINT,MINI,IPOSI)
  1462.             ELSEIF (INU1.EQ.5) THEN
  1463.                CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
  1464.             ELSE
  1465.                 CALL ERREUR(21)
  1466.                 RETURN
  1467.             ENDIF
  1468.  
  1469. C---------------------------- Cas non prevus ---------------------------
  1470.          ELSE
  1471.             CALL ERREUR(21)
  1472.             RETURN
  1473.          ENDIF
  1474.          RETURN
  1475.  
  1476.  
  1477. * +-------------------------------------------------------------------+
  1478. * |                                                                   |
  1479. * |                          L I S T O B J E                          |
  1480. * |                                                                   |
  1481. * +-------------------------------------------------------------------+
  1482.       ELSEIF (CTYP.EQ.'LISTOBJE') THEN
  1483.         CALL LIROBJ('LISTOBJE',ILOBJ,1,IRET)
  1484.         IF (IERR.NE.0) RETURN
  1485.  
  1486. C EXTRACTION DU TYPE DES OBJETS DE LA LISTE
  1487.         CALL LIRCHA(CTEXT,0,IRET)
  1488.         IF (IRET.NE.0) THEN
  1489.           IF (CTEXT(1:4).EQ.'TYPE') THEN
  1490.             MLOBJE = ILOBJ
  1491.             SEGACT,MLOBJE
  1492.             CTYP = TYPOBJ
  1493.             CALL ECRCHA(CTYP)
  1494.             RETURN
  1495.           ENDIF
  1496.         ENDIF
  1497.  
  1498. C EXTRACTION D'UN OBJET DE LA LISTE
  1499.         CALL LIRENT(I1,1,IRET)
  1500.         IF (IERR.NE.0) RETURN
  1501.         IF (I1.LE.0) THEN
  1502.           CALL ERREUR(21)
  1503.           RETURN
  1504.         ENDIF
  1505.         MLOBJE = ILOBJ
  1506.         SEGACT,MLOBJE
  1507.         NOBJ = LISOBJ(/1)
  1508.         IF (I1.GT.NOBJ) THEN
  1509.           INTERR(1) = I1
  1510.           CALL ERREUR(620)
  1511.           RETURN
  1512.         ENDIF
  1513.         IP1  = LISOBJ(I1)
  1514.         CTYP = TYPOBJ
  1515.         CALL ECROBJ(CTYP,IP1)
  1516.         RETURN
  1517.  
  1518.  
  1519. C     FIN IF(CTYP...
  1520.       ENDIF
  1521.  
  1522.  
  1523. ***********************************************************************
  1524. * ON TRAITE LES LISTENTI, LISTREEL ET LISTMOTS SEPAREMENT POUR        *
  1525. * POUVOIR TOLERER L'INVERSION DES DEUX ARGUMENTS (LA LISTE PRINCIPALE *
  1526. * ET L'INDICE/LA LISTE D'INDICES)                                     *
  1527. ***********************************************************************
  1528.  
  1529.  
  1530. * +-------------------------------------------------------------------+
  1531. * |                                                                   |
  1532. * |                   L   I   S   T   M   O   T   S                   |
  1533. * |                                                                   |
  1534. * +-------------------------------------------------------------------+
  1535.    10 CONTINUE
  1536.       CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET)
  1537.       IF (IRET.EQ.0) GOTO 20
  1538.  
  1539.       MLMOT1 = ILMOT1
  1540.       SEGACT , MLMOT1
  1541.       LONMOT = MLMOT1.MOTS(/2)
  1542.       JGN = MLMOT1.MOTS(/1)
  1543.  
  1544. *     ===============================
  1545. *     EXTRACTION DE PLUSIEURS INDICES
  1546. *     ===============================
  1547.       CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1548.       IF ( IRET .EQ. 1 ) THEN
  1549.          MLENTI = ILENT
  1550.          SEGACT , MLENTI
  1551.          JGM = LECT(/1)
  1552.          SEGINI , MLMOT2
  1553.          ILMOT2= MLMOT2
  1554.          DO 1221 I=1 , JGM
  1555.            I_EXTR =LECT(I)
  1556.             IF (( I_EXTR .GT. LONMOT ) .OR. ( I_EXTR .LT. 1 )) THEN
  1557.                INTERR(1) = I_EXTR
  1558.                CALL ERREUR(620)
  1559.             ENDIF
  1560.             MLMOT2.MOTS(I) = MLMOT1.MOTS(I_EXTR)
  1561.  1221    CONTINUE
  1562.          SEGACT , MLMOT2
  1563.          CALL ECROBJ ('LISTMOTS',ILMOT2)
  1564.          RETURN
  1565.  
  1566. *     ===========================
  1567. *     EXTRACTION D'UN SEUL INDICE
  1568. *     ===========================
  1569.       ELSE
  1570.          CALL LIRENT (ILENT,1,IRETOU)
  1571.          IF (IERR .NE. 0) RETURN
  1572.          IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN
  1573.             INTERR(1)=ILENT
  1574.             CALL ERREUR(620)
  1575.          ELSE
  1576.             CTEXT = MLMOT1.MOTS(ILENT)
  1577.          ENDIF
  1578.          CALL ECRCHA(CTEXT(1:JGN))
  1579.          RETURN
  1580.       ENDIF
  1581.  
  1582.  
  1583. * +-------------------------------------------------------------------+
  1584. * |                                                                   |
  1585. * |                   L   I   S   T   R   E   E   L                   |
  1586. * |                                                                   |
  1587. * +-------------------------------------------------------------------+
  1588.    20 CONTINUE
  1589.       CALL LIROBJ('LISTREEL',ILREE1,0,IRET)
  1590.       IF (IRET.EQ.0) GOTO 30
  1591.  
  1592.       MLREE1 = ILREE1
  1593.       SEGACT , MLREE1
  1594.       LONREE = MLREE1.PROG(/1)
  1595.  
  1596. *     ===============================
  1597. *     EXTRACTION DE PLUSIEURS INDICES
  1598. *     ===============================
  1599.       CALL LIROBJ('LISTENTI',ILENT,0,IRET)
  1600.       IF ( IRET .EQ. 1 ) THEN
  1601.          MLENTI = ILENT
  1602.          SEGACT , MLENTI
  1603.          JG = LECT(/1)
  1604.          SEGINI , MLREE2
  1605.          ILREE2= MLREE2
  1606.          DO 1231 I=1 , JG
  1607.            I_EXTR =LECT(I)
  1608.             IF (( I_EXTR .GT. LONREE ) .OR. ( I_EXTR .LT. 1 )) THEN
  1609.                INTERR(1) = I_EXTR
  1610.                CALL ERREUR(620)
  1611.                RETURN
  1612.             ENDIF
  1613.             MLREE2.PROG(I) = MLREE1.PROG(I_EXTR)
  1614.  1231    CONTINUE
  1615.          SEGACT , MLREE2
  1616.          CALL ECROBJ ('LISTREEL',ILREE2)
  1617.          RETURN
  1618.  
  1619. *     ===========================
  1620. *     EXTRACTION D'UN SEUL INDICE
  1621. *     ===========================
  1622.       ELSE
  1623.          CALL LIRENT (ILENT,1,IRETOU)
  1624.          IF (IERR .NE. 0) RETURN
  1625.          IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN
  1626.             INTERR(1)=ILENT
  1627.             CALL ERREUR(620)
  1628.          ELSE
  1629.             REELDP = MLREE1.PROG(ILENT)
  1630.          ENDIF
  1631.          CALL ECRREE(REELDP)
  1632.          RETURN
  1633.       ENDIF
  1634.  124  CONTINUE
  1635.  
  1636.  
  1637. * +-------------------------------------------------------------------+
  1638. * |                                                                   |
  1639. * |                   L   I   S   T   E   N   T   I                   |
  1640. * |                                                                   |
  1641. * +-------------------------------------------------------------------+
  1642.    30 CONTINUE
  1643.       CALL LIROBJ('LISTENTI',ILENT1,0,IRET)
  1644.       IF (IRET.EQ.0) GOTO 999
  1645.  
  1646.       MLENT1 = ILENT1
  1647.       SEGACT , MLENT1
  1648.       LONENT = MLENT1.LECT(/1)
  1649.  
  1650. *     ===============================
  1651. *     EXTRACTION DE PLUSIEURS INDICES
  1652. *     ===============================
  1653.       CALL LIROBJ('LISTENTI',ILENT2,0,IRET)
  1654.       IF ( IRET .EQ. 1 ) THEN
  1655.          MLENT2 = ILENT2
  1656.          SEGACT , MLENT2
  1657.          JG = MLENT2.LECT(/1)
  1658.          SEGINI , MLENT3
  1659.          ILENT3= MLENT3
  1660.          DO I=1 , JG
  1661.             I_EXTR =MLENT2.LECT(I)
  1662.             IF (I_EXTR.GT.LONENT .OR. I_EXTR.LT.1) THEN
  1663.                INTERR(1) = I_EXTR
  1664.                CALL ERREUR(620)
  1665.             ENDIF
  1666.             MLENT3.LECT(I) = MLENT1.LECT(I_EXTR)
  1667.          ENDDO
  1668.          SEGACT , MLENT3
  1669.          CALL ECROBJ ('LISTENTI',ILENT3)
  1670.          RETURN
  1671.  
  1672. *     ===========================
  1673. *     EXTRACTION D'UN SEUL INDICE
  1674. *     ===========================
  1675.       ELSE
  1676.          CALL LIRENT (ILENT,1,IRETOU)
  1677.          IF (IERR .NE. 0) RETURN
  1678.          IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN
  1679.             INTERR(1)=ILENT
  1680.             CALL ERREUR(620)
  1681.          ELSE
  1682.             INTEGR = MLENT1.LECT(ILENT)
  1683.          ENDIF
  1684.          CALL ECRENT(INTEGR)
  1685.          RETURN
  1686.       ENDIF
  1687.  
  1688.  
  1689. * +-------------------------------------------------------------------+
  1690. * |   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   |
  1691. * +-------------------------------------------------------------------+
  1692.   999 CONTINUE
  1693.       CALL ERREUR(676)
  1694.  
  1695.       END
  1696.  
  1697.  
  1698.  

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