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

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