C EXTRAI SOURCE GOUNAND 25/03/24 21:15:02 12215 SUBROUTINE EXTRAI ************************************************************************ * NOM : EXTRAI * DESCRIPTION : OPERATION D'EXTRACTION POUR DIFFERENTS TYPES D'OBJETS ************************************************************************ * HISTORIQUE : 5/12/1985 : PASCAL MANIGOT : creation de la subroutine * HISTORIQUE : MODIFIE EN SEPTEMBRE 1994 * HISTORIQUE : MODIFIE EN AVRIL 2015 PAR CB215821 * ==> Extraire le MAILLAGE d'un MMODEL vide renvoie * un MAILLAGE vide au lieu d'une GEMAT ERROR * ==> Extraire un constituant d'un MMODEL vide * renvoie une erreur au lieu d'une GEMAT ERROR * HISTORIQUE : MODIFIE EN JANVIER 2016 PAR JCARDO * ==> ajout de la syntaxe EXTR LCHPO1 "VALE" ... * ==> extension du IF/ELSEIF/ENDIF principal a * tous les objets * ==> amelioration de la lisibilite de la subroutine ************************************************************************ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCHAMP -INC SMCOORD -INC SMSUPER -INC SMRIGID -INC SMELEME -INC SMCHPOI -INC SMBASEM -INC SMTABLE -INC SMDEFOR -INC SMMODEL -INC SMEVOLL -INC SMLREEL -INC SMLENTI -INC SMLMOTS -INC SMLCHPO -INC SMNUAGE -INC SMLOBJE -INC SMCHAML SEGMENT LIMODE(0) PARAMETER (NBFORM=100 , NBCHGT=10) PARAMETER (NLOMAX=5, NBCMOC=25) CHARACTER*4 MNLOCA(NLOMAX) CHARACTER*4 CAMPL(1), MOOPT(7), NOMU(3), LMOSU(5), MOTBAS(5), & NUMO(5), MCHGT(NBCHGT), CMOC(NBCMOC), CFROT(1) CHARACTER*16 MOFORM(NBFORM) CHARACTER*4 MOT_4 CHARACTER*(LOCOMP) CMOT,MOT1,MOT2,MOCOMP CHARACTER*8 MOT_8,CTYP,CTYP1 CHARACTER*(LOCHAI) CTEXTL,CTEXT CHARACTER*(LCONMO) MOT_CM LOGICAL LTELQ, LAG,BORINF,MINI,IMFRO,ZHARM C DATA LMOSU /'RIGI','ELEM','RIGT','MASS','BLOQ'/ DATA NOMU /'NOMU','MULT','UNIL'/ DATA MOOPT /'MAIL','RIGI','SYME','ANTI','CONT','COMP','DIAG'/ DATA MOTBAS/'RIGI','MASS','MODE','STAT','PSMO'/ DATA CAMPL /'AMPL'/ DATA NUMO /'INFE','SUPE','MINI','MAXI','ENTR'/ DATA CMOC /'MAIL','ZONE','FORM','CONS','ELEM','GEOM','CONT', $ 'DEFO','DEPL','FORC','GRAD','GRAF','MATE','CONP', $ 'TEMP','VARI','PARA','DEIN','COMP','OBJE','NON_', $ 'NLOC','PHAS','CENT','HHO_'/ DATA CFROT /'FROT'/ DATA MCHGT /'CHAR','CHAM','TRAJ','EVOL','VITE','COMP', & 'LIE ','LIBR','LOBJ','LREE'/ XVAL1=0.D0 MOT_4=' ' MINI =.FALSE. ILO =0 IOBIN=0 IVALRE=0 C CALL QUETYP(CTYP,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL ERREUR(533) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | M O T | * | | * +-------------------------------------------------------------------+ IF (CTYP.EQ.'MOT ') THEN CALL LIRCHA(CTEXTL,1,LONMOT) IF (IERR.NE.0) RETURN * ============================ * EXTRACTION D'UNE SOUS-CHAINE * ============================ CALL QUETYP(CTYP1,0,IRETOU) IF (IRETOU.NE.0) THEN IF (CTYP1.EQ.'ENTIER'.OR.CTYP1.EQ.'LISTENTI') THEN CALL SOUCHA(CTEXTL,LONMOT,CTYP1) RETURN ENDIF ENDIF * ======================================================== * CREATION D'UNE TABLE CONTENANT LES OBJETS DE TYPE CTEXTL * ======================================================== MOT_8=CTEXTL(1:8) CALL REPERT(MOT_8,IA) M=IA SEGINI MTABLE MLOTAB=0 DO 7765 I=1,IA IF(MOT_8.EQ.'FLOTTANT' ) THEN CALL LIRREE(XVAL,1,IRETOU) ELSEIF(MOT_8.EQ.'LOGIQUE ') THEN CALL LIRLOG(LAG,1,IRETOU) ELSEIF (MOT_8.EQ.'ENTIER ') THEN CALL LIRENT(IVAL,1,IRETOU) ELSEIF(MOT_8.EQ.'MOT ') THEN CALL LIRCHA(CTEXT,1,IRETOU) ELSE CALL LIROBJ(MOT_8,IVAL,1,IRETOU) ENDIF CALL ECCTAB(MTABLE,'ENTIER ',I,XVAL1,MOT_4,MINI,ILO, $ MOT_8,IVAL,XVAL,CTEXT(1:IRETOU),LAG,IVAL) 7765 CONTINUE SEGDES MTABLE CALL ECROBJ('TABLE ',MTABLE) RETURN * +-------------------------------------------------------------------+ * | | * | D E F O R M E E | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'DEFORME ') THEN CALL LIROBJ('DEFORME ',MDEFOR,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRMOT(CAMPL,1,IRET,1) IF(IERR.NE.0) RETURN SEGACT MDEFOR IF (AMPL(/1).NE.1) THEN CALL ERREUR(475) ELSE AMP=AMPL(1) CALL ECRREE(AMP) ENDIF RETURN * +-------------------------------------------------------------------+ * | | * | B A S E M O D A | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'BASEMODA') THEN CALL LIROBJ('BASEMODA',IPBASE,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRMOT(MOTBAS,5,IRET,1) IF(IERR.NE.0) RETURN MOT_4=MOTBAS(IRET) CALL EXTRA7(IPBASE,MOT_4,IPTR) IF(IERR.NE.0) RETURN IF (IRET.LE.2) THEN CALL ECROBJ('RIGIDITE',IPTR) ELSE CALL ECROBJ('SOLUTION',IPTR) ENDIF RETURN * +-------------------------------------------------------------------+ * | | * | E V O L U T I O N | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'EVOLUTIO') THEN CALL LIROBJ('EVOLUTIO',IBOLL,1,IRETOU) CALL ACTOBJ('EVOLUTIO',IBOLL,1) IF(IERR.NE.0) RETURN CALL EXTRA6 (IBOLL) RETURN * +-------------------------------------------------------------------+ * | | * | S U P E R E L E | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'SUPERELE') THEN CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU) IF (IERR.NE.0) RETURN CALL LIRMOT(LMOSU,5,IRET,1) IF (IERR.NE.0) RETURN SEGACT MSUPER * ============== * MOT-CLE "RIGI" * ============== IF (IRET.EQ.1) THEN IPTR=MSURAI CALL ECROBJ('RIGIDITE',IPTR) * ============== * MOT-CLE "ELEM" * ============== ELSEIF (IRET.EQ.2) THEN IPTR=MSUPEL CALL ECROBJ('MAILLAGE',IPTR) * ============== * MOT-CLE "RIGT" * ============== ELSEIF (IRET.EQ.3) THEN IPTR=MRIGTO CALL ECROBJ('RIGIDITE',IPTR) * ============== * MOT-CLE "MASS" * ============== ELSEIF (IRET.EQ.4) THEN IPTR=MSUMAS CALL ECROBJ('RIGIDITE',IPTR) * ============== * MOT-CLE "BLOQ" * ============== ELSEIF (IRET.EQ.5) THEN NRIGEL=MBLOQU RI1=MRIGTO SEGACT,RI1 SEGINI,MRIGID MTYMAT=RI1.MTYMAT DO 1 IE1=1,NRIGEL COERIG(IE1)=RI1.COERIG(IE1) DO 11 IE2=1,8 IRIGEL(IE2,IE1)=RI1.IRIGEL(IE2,IE1) 11 CONTINUE 1 CONTINUE SEGACT,MRIGID CALL ECROBJ('RIGIDITE',MRIGID) ENDIF RETURN * +-------------------------------------------------------------------+ * | | * | M A T R I K | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'MATRIK') THEN CALL LIROBJ ('MATRIK',IBOGID,1,IRETOU) IF (IERR.NE.0) RETURN CALL LIRMOT(MOOPT,7,IRET,0) * ==================================================== * EXTRACTION D'UNE SOUS-MATRICE DE COMPOSANTES DONNEES * ==================================================== IF (IRET.EQ.0) THEN CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM) IF (IRETLM.EQ.1) THEN CALL LIROBJ('LISTMOTS',MLMOT2,0,IRET) IF (IRET.NE.1) THEN CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,0,MLMOT2) IF (IERR.NE.0) RETURN ENDIF ELSE CALL LIRCHA(MOT1,1,IRET) IF (IERR.NE.0) RETURN JGN=4 JGM=1 SEGINI MLMOT1 MLMOT1.MOTS(1)=MOT1 CALL LIRCHA(MOT2,0,IRET) IF (IRET.EQ.0) THEN CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,0,MLMOT2) IF (IERR.NE.0) RETURN ELSE SEGINI MLMOT2 MLMOT2.MOTS(1)=MOT2 ENDIF ENDIF CALL EXINCK(IBOGID,MLMOT1,MLMOT2,IOUT,IMPR,IRET) IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2 IF (IERR.NE.0) RETURN CALL ECROBJ('MATRIK',IOUT) RETURN * ============================================ * MOT-CLE "DIAG" => EXTRACTION DE LA DIAGONALE * ============================================ ELSEIF (IRET.EQ.7) THEN CALL ECROBJ('MATRIK',IBOGID) CALL EXDIAG(1) RETURN * ======================================================= * MOT-CLE "COMP => EXTRACTION DE LA LISTE DES COMPOSANTES * ======================================================= ELSEIF(IRET.EQ.6) THEN CALL LIRCHA(CMOT,0,ICDUAL) IF (ICDUAL.NE.0) THEN IF (CMOT.NE.'DUAL') THEN MOTERR=CMOT CALL ERREUR(7) RETURN ENDIF ENDIF CALL EXTR26(IBOGID,ICDUAL,IPLSTM) CALL ECROBJ('LISTMOTS',IPLSTM) RETURN ELSE MOTERR=MOOPT(IRET) CALL ERREUR(7) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | R I G I D I T E | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'RIGIDITE') THEN CALL LIROBJ ('RIGIDITE',IBOGID,1,IRETOU) IF (IERR.NE.0) RETURN CALL LIRMOT(MOOPT,7,IRET,0) * ==================================================== * EXTRACTION D'UNE SOUS-MATRICE DE COMPOSANTES DONNEES * ==================================================== IF (IRET.EQ.0) THEN CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM) IF (IRETLM.EQ.1) THEN CALL LIROBJ('LISTMOTS',MLMOT2,0,IRET) IF (IRET.NE.1) THEN CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,1,MLMOT2) IF (IERR.NE.0) RETURN ENDIF ELSE CALL LIRCHA(MOT1,1,IRET) IF (IERR.NE.0) RETURN JGN=4 JGM=1 SEGINI MLMOT1 MLMOT1.MOTS(1)=MOT1 CALL LIRCHA(MOT2,0,IRET) IF (IRET.EQ.0) THEN CALL LMOCHA(MLMOT1,NOMDD,LNOMDD,NOMDU,LNOMDU,1,MLMOT2) IF (IERR.NE.0) RETURN ELSE SEGINI MLMOT2 MLMOT2.MOTS(1)=MOT2 ENDIF ENDIF CALL EXINCR(IBOGID,MLMOT1,MLMOT2,IOUT) IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2 IF (IERR.NE.0) RETURN CALL ECROBJ('RIGIDITE',IOUT) RETURN * ============================================ * MOT-CLE "DIAG" => EXTRACTION DE LA DIAGONALE * ============================================ ELSEIF (IRET.EQ.7) THEN CALL EXDIAR(IBOGID,ICHP) IF (IERR.NE.0) RETURN CALL ACTOBJ('CHPOINT ',ICHP,1) CALL ECROBJ('CHPOINT ',ICHP) RETURN * ======================================================== * MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES * ======================================================== ELSEIF(IRET.EQ.6) THEN CALL LIRCHA(CMOT,0,ICDUAL) IF (ICDUAL.NE.0) THEN IF (CMOT.NE.'DUAL') THEN MOTERR=CMOT CALL ERREUR(7) RETURN ENDIF ENDIF CALL EXTR16(IBOGID,ICDUAL,IPLSTM) CALL ECROBJ('LISTMOTS',IPLSTM) RETURN * ==================================== * MOT-CLE "CONT" => APPUIS UNILATERAUX * ==================================== ELSEIF(IRET.EQ.5) THEN MRIGID=IBOGID SEGACT MRIGID ISOPE= ISUPEQ IF(ISUPEQ.EQ.0) CALL CRTABL(ISOPE) MTABLE=ISOPE SEGDES MTABLE CALL ECROBJ('TABLE ',ISOPE) RETURN * ============================================================== * MOTS-CLES "SYME" OU "ANTI" => SOUS-MATRICES (ANTI-)SYMETRIQUES * ============================================================== ELSEIF (IRET.EQ.3 .OR. IRET.EQ.4) THEN CALL EXTR13(IBOGID,IRET) RETURN ENDIF * ============================================================= * MOTS-CLES "MAIL" OU "RIGI" => SOUS-MAILLAGES OU SOUS-MATRICES * ============================================================= ICO=0 IMO=3 IF(IRET.EQ.2) THEN ICO=1 IMO=2 ENDIF CALL LIRMOT(NOMU,IMO,IMUL,ICO) IF(IERR.NE.0) RETURN * ************************************************ * MATRICE AVEC SEULEMENT LES MULT. DE LAGRANGE OU * AVEC TOUT SAUF LES MULT. DE LAGRANGE * ************************************************ IF (IRET.EQ.2) THEN CALL SEPA(IBOGID,IMUL) CALL ECROBJ('RIGIDITE',IBOGID) RETURN ENDIF * ******************************************************** * MAILLAGE PARTIEL * "NOMU" => TOUT SAUF LES MULT. DE LAGRANGE * "MULT" => TOUS LES MULT. DE LAGRANGE * "UNIL" => SEULEMENT LES MULT. ASSOCIES AUX COND. UNIL. * ******************************************************** IF (IMUL.NE.0) THEN CALL POIRIG(IBOGID,IMUL) RETURN ENDIF * **************** * MAILLAGE COMPLET * **************** IF (IERR.NE.0) RETURN CALL MELRIG(IBOGID,IPP1) CALL ACTOBJ('MAILLAGE',IPP1,1) CALL ECROBJ('MAILLAGE',IPP1) RETURN * +-------------------------------------------------------------------+ * | | * | C H P O I N T | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'CHPOINT') THEN CALL LIROBJ('CHPOINT ',IBOPOI,1,IRETOU) IF (IERR.NE.0) RETURN CALL ACTOBJ('CHPOINT ',IBOPOI,1) IF (IERR.NE.0) RETURN CALL LIRCHA(CMOT,1,IRETOU) IF (IERR.NE.0) RETURN MOT_4=CMOT * ===================================== * MOT-CLE "TITR" => EXTRACTION DU TITRE * ===================================== IF (MOT_4.EQ.'TITR') THEN MCHPOI = IBOPOI CTEXT = MOCHDE ILON = LEN(CTEXT) DO 100 I = ILON,1,-1 IF (CTEXT(I:I).NE.' ') THEN NLON = I GOTO 102 ENDIF 100 CONTINUE NLON = 1 102 CONTINUE CALL ECRCHA(CTEXT(1:NLON)) RETURN * ========================================= * MOT-CLE "NATU" => EXTRACTION DE LA NATURE * ========================================= ELSEIF (MOT_4.EQ.'NATU') THEN MCHPOI = IBOPOI INAT = JATTRI(1) IF (INAT.EQ.0) CTEXT(1:11) = 'INDETERMINE' IF (INAT.EQ.1) CTEXT(1:11) = 'DIFFUS ' IF (INAT.EQ.2) CTEXT(1:11) = 'DISCRET ' CALL ECRCHA(CTEXT(1:11)) RETURN * =================================================== * MOT-CLE "MAIL" => EXTRACTION DU SUPPORT GEOMETRIQUE * =================================================== ELSEIF (MOT_4 .EQ.'MAIL') THEN IMUL=0 CALL LIRMOT(NOMU,1,IMUL,0) IF (IERR.NE.0) RETURN CALL EXTR21(IBOPOI,IMUL,IPP1) IF (IERR.NE.0) RETURN CALL ACTOBJ('MAILLAGE',IPP1,1) CALL ECROBJ('MAILLAGE',IPP1) RETURN * ======================================================== * MOT-CLE "COMP" => EXTRACTION DE LA LISTE DES COMPOSANTES * ======================================================== ELSEIF (MOT_4 .EQ.'COMP') THEN CALL EXTR11(IBOPOI,KLISTM) CALL ECROBJ('LISTMOTS',KLISTM) RETURN * ==================================== * MOT-CLE "TYPE" => EXTRACTION DU TYPE * ==================================== ELSEIF (MOT_4.EQ.'TYPE') THEN MCHPOI = IBOPOI MOT_8 = MTYPOI CALL ECRCHA(MOT_8(1:8)) RETURN * ============================================================ * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN PLUSIEURS POINTS * ET POUR PLUSIEURS COMPOSANTES * ============================================================ ELSEIF (MOT_4.EQ.'VALE') THEN * * LISTE DES COMPOSANTES (OBJET MOT OU LISTMOTS) CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU) IF (IRETOU.EQ.1) THEN SEGACT,MLMOTS ELSE CALL LIRCHA(MOCOMP,0,IRETOU) IF (IRETOU.GT.0) THEN JGN=LOCOMP JGM=1 SEGINI,MLMOTS MOTS(1)=MOCOMP SEGACT,MLMOTS ENDIF ENDIF * * LISTE DES NOEUDS (OBJET POINT OU MAILLAGE DE POI1) CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU) IF (IRETOU.EQ.1) THEN CALL ACTOBJ('MAILLAGE',MELEME,1) ELSE CALL LIROBJ('POINT',IPOINT,0,IRETOU) IF (IRETOU.NE.0) THEN CALL CRELEM(IPOINT) MELEME=IPOINT ENDIF ENDIF * * MOT-CLE 'NOID' IVID=0 CALL LIRCHA(MOT_4,0,IRETOU) IF (IRETOU.NE.0) THEN IF (MOT_4.EQ.'NOID') THEN IVID=1 ELSE MOTERR(1:4)=MOT_4 MOTERR(5:40)='NOID' CALL ERREUR(1052) RETURN ENDIF ENDIF * * APPEL A EXTR23 CALL EXTR23(IBOPOI,MLMOTS,MELEME,MLREEL,IVID) IF (IERR.NE.0) RETURN SEGACT,MLREEL CALL ECROBJ('LISTREEL',MLREEL) RETURN * =========================================================== * PAS DE MOT CLE : CMOT = NOM DE COMPOSANTE * EXTRACTION DE LA VALEUR EN UN POINT D'UNE COMPOSANTE DONNEE * =========================================================== ELSE CALL LIROBJ('POINT ',MPOINT,1,IRETOU) IF (IRETOU.EQ.0) THEN MOTERR(1:8)='POINT' CALL ERREUR(37) RETURN ENDIF c lecture facultative de l'harmonique de Fourier CALL LIRENT(NHARM,0,IRET) ZHARM=IRET.EQ.1 CALL EXTRA9(IBOPOI,MPOINT,CMOT,NHARM,ZHARM,XFLOT,IRET) CALL ECRREE(XFLOT) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | M C H A M L | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'MCHAML') THEN CALL LIROBJ('MCHAML ',IPCHE1,1,IRET) IF (IERR.NE.0) RETURN C CALL LIRCHA(CMOT,1,IRET0) IF (IERR.NE.0) RETURN MOT_4=CMOT ICOD=1 IF (MOT_4.EQ.'CONF') ICOD=2 CALL ACTOBJ('MCHAML ',IPCHE1,ICOD) * ================================================ * MOTS-CLES "CONF" CONFIGURATION DU CHAMP * ================================================ IF (MOT_4.EQ.'CONF') THEN mchelm=ipche1 segact mchelm mcnf=mclcnf if (mcnf.eq.0) mcnf=mcoord CALL ECROBJ('CONFIGUR',mcnf) RETURN * ================================================ * MOTS-CLES "DEVA" OU "COVA" => NOMS DES VARIABLES * ================================================ ELSEIF (MOT_4.EQ.'DEVA' .OR. MOT_4.EQ.'COVA') THEN CALL EXCHA1(IPCHE1,ILISR,MOT_4) IF (ILISR.NE.0) THEN CALL ACTOBJ('LISTMOTS',ILISR,1) CALL ECROBJ('LISTMOTS',ILISR) ENDIF RETURN * ================================= * MOT-CLE "NBZO" => NOMBRE DE ZONES * ================================= ELSEIF (MOT_4.EQ.'NBZO') THEN CALL EXTR18(IPCHE1,NBZONE) if (ierr.ne.0) return CALL ECRENT(NBZONE) RETURN * ===================================================== * MOT-CLE "COMP" => EXTRACTION DES NOMS DES COMPOSANTES * ===================================================== ELSEIF (MOT_4.EQ.'COMP' ) THEN CALL LIROBJ('MMODEL',IPMODL,0,IRETM) C C RECHERCHE DES NOMS DES COMPOSANTES APPARTENANT C A LA ZONE DU MODELE IF (IRETM.NE.0) THEN CALL ACTOBJ('MMODEL',IPMODL,1) CALL EXTR15(IPMODL,IPCHE1,IPLSTM) IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM) RETURN C C RECHERCHE DES NOMS DE TOUTES LES COMPOSANTES ELSE CALL EXTR17(IPCHE1,IPLSTM) CALL ECROBJ('LISTMOTS',IPLSTM) RETURN ENDIF * ====================================================== * MOT-CLE "CONS" => EXTRACTION DES NOMS DES CONSTITUANTS * ====================================================== ELSEIF(MOT_4.EQ.'CONS' ) THEN CALL LIROBJ('MMODEL',IPMODL,0,IRETM) C C RECHERCHE DES NOMS DES CONSTITUANTS APPARTENANT C A LA ZONE DU MODELE IF (IRETM.NE.0) THEN CALL ACTOBJ('MMODEL',IPMODL,1) CALL EXTR35(IPMODL,IPCHE1,IPLSTM) IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM) RETURN C C RECHERCHE DES NOMS DE TOUs LES constituants ELSE CALL EXTR37(IPCHE1,IPLSTM) CALL ECROBJ('LISTMOTS',IPLSTM) RETURN ENDIF * ================================================== * MOT-CLE "VALE" => EXTRACTION DE TOUTES LES VALEURS * ================================================== ELSEIF(MOT_4.EQ.'VALE' ) THEN CALL LIRCHA(CMOT,1,IRET0) IF (IERR.NE.0) RETURN CALL EXTR25(IPCHE1,CMOT) RETURN * ========================================================= * EXTRACTION D'UNE VALEUR, DU TITRE, DU TYPE OU DU MAILLAGE * ========================================================= ELSE IF (MOT_4.NE.'TITR'.AND.MOT_4.NE.'TYPE'.AND. & MOT_4.NE.'MAIL') THEN IENT1 = 0 IENT2 = 0 IENT3 = 0 IPMAIL = 0 CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET0) IF (IRET0.NE.0) THEN CALL ACTOBJ('MAILLAGE',IPMAIL,1) IF (IERR.NE.0) RETURN MELEME = IPMAIL NBEL1 = NUM(/2) IF (NBEL1.NE.1) THEN CALL ERREUR(426) RETURN ENDIF IENT3 = 0 CALL LIRENT(IENT3,0,IRET3) IF (IRET3.NE.0.AND.IENT3.LE.0) THEN INTERR(1) = IENT3 CALL ERREUR(36) RETURN ENDIF ELSE IPMAIL = 0 CALL LIRENT(IENT1,1,IRET1) IF(IRET1.EQ.0) RETURN IF (IENT1.LE.0) THEN INTERR(1) = IENT1 CALL ERREUR(36) RETURN ENDIF CALL LIRENT(IENT2,1,IRET2) IF(IRET2.EQ.0) RETURN IF (IENT2.LE.0) THEN INTERR(1) = IENT2 CALL ERREUR(36) RETURN ENDIF CALL LIRENT(IENT3,1,IRET3) IF(IRET3.EQ.0) RETURN IF (IENT3.LE.0) THEN INTERR(1) = IENT3 CALL ERREUR(36) RETURN ENDIF ENDIF ENDIF CALL EXTR14(IPCHE1,IENT1,IENT2,IENT3,CMOT,IPMAIL) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | M M O D E L | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'MMODEL') THEN CALL LIROBJ('MMODEL',IPMODL,1,IRET) CALL ACTOBJ('MMODEL',IPMODL,1) IF (IERR.NE.0) RETURN CALL LIRMOT(CMOC,NBCMOC,IRET,1) IF(IERR.NE.0) RETURN CMOT =CMOC(IRET) MOT_4 =CMOT C Extension du MMODEL en cas de modele de MELANGE CALL MODETE(IPMODL,MMODEL,IMELAN) NSOUS=MMODEL.KMODEL(/1) C=DEB==== FORMULATION HHO ==== Cas particulier ========================= IF (MOT_4.EQ.'HHO_') THEN CALL REFUS CALL LIRCHA(CTEXT,1,iret) IF (IERR.NE.0) RETURN CALL HHOEXT(IPMODL,CTEXT, IPP1,CTYP,iret) IF (iret.NE.0) THEN CALL ERREUR(iret) RETURN END IF IF (IPP1.LE.0) THEN CALL ERREUR(21) RETURN END IF CALL ACTOBJ(CTYP,IPP1,1) CALL ECROBJ(CTYP,IPP1) RETURN END IF C=FIN==== FORMULATION HHO ============================================== IF (MOT_4.EQ.'MAIL') THEN IMFRO=.FALSE. CALL LIRMOT(CFROT,1,IRET,0) IF (IRET.EQ.1) THEN IMFRO=.TRUE. ENDIF IPP1=0 ltelq=.false. DO 1116 I=1,NSOUS IMODEL= KMODEL(I) IF (IMFRO) THEN NMATT=MATMOD(/2) CALL PLACE(MATMOD,NMATT,IPLAC,'FROTTANT') if(iplac.eq.0) goto 1116 ENDIF IPP2 = IMAMOD IF (ipp1.eq.0) then ipp1=ipp2 ELSE CALL FUSE (IPP1,IPP2,IRET,ltelq) IPP1=IRET ENDIF 1116 CONTINUE IF(IPP1.EQ.0) THEN C Cas du resultat vide ==> MAILLAGE VIDE NBELEM = 0 NBNN = NBNNE(ILCOUR) NBREF = 0 NBSOUS = 0 SEGINI,MELEME ITYPEL = ILCOUR IPP1 = MELEME ENDIF CALL ACTOBJ('MAILLAGE',IPP1,1) CALL ECROBJ('MAILLAGE',IPP1) RETURN ELSEIF (MOT_4.eq.'COMP') THEN CALL LIRCHA(MOFORM(1),1,iretou) if(ierr.ne.0) return N1=0 SEGINI,MMODE1 DO 5497 I=1,NSOUS IMODEL=KMODEL(I) DO IB=1,MATMOD(/2) IF( MATMOD(IB) .EQ. MOFORM(1) ) GOTO 5498 ENDDO GOTO 5497 5498 CONTINUE N1=N1+1 MMODE1.KMODEL(**)=KMODEL(I) 5497 CONTINUE IF(N1.GE.0.AND.N1.LT.NSOUS) THEN SEGADJ,MMODE1 ELSEIF(N1.EQ.NSOUS)THEN C Pas la peine de creer un autre MMODEL SEGSUP,MMODE1 MMODE1=MMODEL ELSE CALL ERREUR(5) ENDIF CALL ACTOBJ('MMODEL ',MMODE1,1) CALL ECROBJ('MMODEL ',MMODE1) RETURN ELSEIF(MOT_4.EQ.'OBJE') THEN if(NSOUS.ne.1) then WRITE(IOIMP,*) ' Dans extrai.eso : ' WRITE(IOIMP,*) ' ce n est pas un modele elementaire' WRITE(IOIMP,*) ' it is not an elementary model' call erreur(19) return endif imodel=kmodel(1) iob=ivamod(/1) do io=iob,1,-1 ctyp=tymode(io) if( ctyp.eq.'ENTIER') then call ecrent(ivamod(io)) else ipoin1=ivamod(io) call ecrobj(ctyp,ipoin1) endif enddo return ELSEIF (MOT_4.EQ.'ZONE') THEN C- Option 'ZONE' 'CONS' => IZOCO=1 IZOCO = 0 CALL LIRMOT(CMOC(4),1,IZOCO,0) IF (IERR.NE.0) RETURN INCTS = 2 IF (IZOCO.EQ.1) INCTS = 3 M = INCTS * NSOUS N1 = 1 SEGINI MTABLE DO IOK=1,NSOUS IMODEL=KMODEL(IOK) NFOR=FORMOD(/2) C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT CALL PLACE (FORMOD,NFOR,IDARC,'DARCY') CALL PLACE (FORMOD,NFOR,IEULE,'EULER') CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES') IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN SEGINI,IMODE1=IMODEL IMODE1.INFMOD(2)=0 IMODEL=IMODE1 ENDIF SEGINI MMODE1 MMODE1.KMODEL(1) = IMODEL IVALI1 = (IOK-1)*INCTS + 1 IPP1 = MMODE1 CALL ECCTAB(MTABLE,'ENTIER ',IVALI1,XFLOT,MOT_8,LAG, $ IOBIN,'MMODEL ',IVALRE,XFLOT,MOT_8,LAG,IPP1) IVALI1 = IVALI1 + 1 IPP1 = IMAMOD CALL ECCTAB(MTABLE,'ENTIER ',IVALI1,XFLOT,MOT_8,LAG, $ IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP1) IF (IZOCO.EQ.1) THEN IVALI1 = IVALI1 + 1 MOT_CM = CONMOD CALL ECCTAB(MTABLE,'ENTIER ',IVALI1,XFLOT,MOT_8,LAG, $ IOBIN,'MOT ',IVALRE,XFLOT,MOT_CM,LAG,IPP1) ENDIF C SEGDES IMODEL ENDDO CALL ECROBJ('TABLE ',MTABLE) RETURN ELSEIF (MOT_4.EQ.'FORM'.OR.MOT_4.EQ.'CONS'.OR.MOT_4.EQ.'ELEM' & .OR. MOT_4.EQ.'MATE'.OR.MOT_4.EQ.'NON_' & .OR.MOT_4.EQ.'PHAS') THEN INFOR=1 IF (MOT_4.EQ.'MATE'.OR.MOT_4.EQ.'PHAS') THEN IPASS=0 ICOND=0 1191 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO) IF (IERR.NE.0) RETURN IPASS=IPASS+1 IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN CALL NOVARD(MMODEL,MOT_4) RETURN ENDIF IF (IRETO.NE.0) THEN INFOR=INFOR+1 IF (INFOR.GT.NBFORM) THEN CALL ERREUR(5) RETURN ENDIF GOTO 1191 ENDIF ELSE ICOND=1 1192 CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO) IF (IERR.NE.0) RETURN ICOND=0 IF (IRETO.NE.0) THEN INFOR=INFOR+1 IF (INFOR.GT.NBFORM) THEN CALL ERREUR(5) RETURN ENDIF GOTO 1192 ENDIF ENDIF INFOR=INFOR-1 C JGN=4 JGM=0 SEGINI MLMOTS MLNONL=MLMOTS C MMODE1=MMODEL IF (NSOUS .EQ. 0) THEN C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous C partie CALL ECROBJ('MMODEL ',IPMODL) RETURN ELSE N1=NSOUS SEGINI,MMODEL IPP1=MMODEL NZON=0 IMECAF=0 DO 1119 I=1,NSOUS IMODEL=MMODE1.KMODEL(I) IF(MOT_4.EQ.'FORM') THEN NFOR=FORMOD(/2) IF(NFOR.NE.INFOR) GOTO 1119 IF(NFOR.EQ.1) THEN IF(MOFORM(1).NE.FORMOD(1)) GOTO 1119 ELSEIF(NFOR.EQ.2) THEN IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE. $ FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND. $ (MOFORM(2).NE.FORMOD(1))))GOTO 1119 ELSE GOTO 1118 ENDIF ELSEIF (MOT_4.EQ.'CONS') THEN DO 425 IJ=1,INFOR C on enleve les espaces au debut et a la fin idim0=LEN(MOFORM(IJ)) idim1=CONMOD(/1) ideb0=0 ifin0=0 ideb1=0 ifin1=0 DO ii=1,idim0 IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ') $ ideb0=ii IF(ifin0.EQ.0.AND. & MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ') & ifin0=idim0-ii+1 ENDDO DO ii=1,idim1 IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii IF(ifin1.EQ.0.AND. & CONMOD(idim1-ii+1:idim1-ii+1).NE.' ') & ifin1=idim1-ii+1 ENDDO C print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1 IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1)) & GOTO 429 425 CONTINUE GOTO 1119 ELSEIF (MOT_4.EQ.'ELEM') THEN DO 426 IJ=1,INFOR IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GOTO 429 426 CONTINUE GOTO 1119 ELSEIF(MOT_4.EQ.'MATE') THEN NMAT=MATMOD(/2) DO 427 IJ=1,INFOR DO 4275 JJ=1,NMAT IF(MATMOD(JJ).EQ.MOFORM(IJ)) GOTO 429 4275 CONTINUE 427 CONTINUE GOTO 1119 ELSEIF(MOT_4.EQ.'NON_') THEN MN3=INFMOD(/1) IF(MN3.LE.12) GOTO 1119 INLOC=-1*INFMOD(13) IF(INLOC.EQ.0) GOTO 1119 CALL MODNLO(MNLOCA,NLODIM) DO 428 IJ=1,INFOR IF(MNLOCA(INLOC).EQ.MOFORM(IJ)(1:4)) GOTO 429 428 CONTINUE GOTO 1119 ELSEIF(MOT_4.EQ.'PHAS' & .AND.CONMOD.NE.' ') THEN DO 430 IJ=1,INFOR IF(CONMOD(17:24).EQ.MOFORM(IJ)(1:8)) GOTO 429 430 CONTINUE GOTO 1119 ENDIF C on vient ici pour prendre les sous modeles 429 CONTINUE NZON=NZON+1 NFOR=FORMOD(/2) C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT CALL PLACE (FORMOD,NFOR,IDARC,'DARCY') CALL PLACE (FORMOD,NFOR,IEULE,'EULER') CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES') IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN IMECAF=1 SEGINI,IMODE1=IMODEL IMODE1.INFMOD(2)=0 IMODEL=IMODE1 ENDIF KMODEL(NZON)=IMODEL 1119 CONTINUE ENDIF C IF(NZON.EQ.0) GOTO 1118 IF(NZON.EQ.NSOUS .AND. IMECAF.EQ.0) THEN C Le SOUS-MODELE demande est le MODELE d'origine CALL ECROBJ('MMODEL ',IPMODL) ELSE IF(NZON.NE.NSOUS)THEN N1=NZON SEGADJ,MMODEL ENDIF CALL ACTOBJ('MMODEL ',IPP1,1) CALL ECROBJ('MMODEL ',IPP1) ENDIF RETURN 1118 CONTINUE CALL ERREUR(610) RETURN ELSEIF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN CALL NOVARD(MMODEL,MOT_4) RETURN ELSEIF (IRET.EQ.22) THEN JGN=4 JGM=0 SEGINI MLMOTS MLNONL=MLMOTS C MMODE1=MMODEL NSOUS=MMODE1.KMODEL(/1) C C TRAITEMENT DES SOUS-MODELES VIDES dont on veut extraire une sous C partie IF (NSOUS .EQ. 0) THEN SEGACT,MLMOTS CALL ECROBJ('LISTMOTS',MLMOTS) RETURN ELSE DO 1122 I=1,NSOUS IMODEL=MMODE1.KMODEL(I) NFOR=FORMOD(/2) IF(NFOR.GE.1) THEN IF (FORMOD(1).NE.'MECANIQUE'.AND. & FORMOD(1).NE.'POREUX') GOTO 1123 MN3=INFMOD(/1) IF(MN3.LE.12) GOTO 1123 INONL=INFMOD(14) IF(INONL.EQ.0) GOTO 1123 MLMOT1=INONL SEGACT MLMOT1 NMONL=MLMOT1.MOTS(/2) IF(NMONL.EQ.0)GOTO 1123 IF(JGM.EQ.0) THEN JGM=NMONL SEGADJ,MLMOTS DO IJ=1,NMONL MOTS(IJ)=MLMOT1.MOTS(IJ) ENDDO ELSE DO IJ=1,NMONL CALL PLACE(MOTS,JGM,IPLA,MLMOT1.MOTS(IJ)) IF(IPLA.EQ.0) THEN JGM=JGM+1 SEGADJ,MLMOTS MOTS(JGM)=MLMOT1.MOTS(IPLA) ENDIF ENDDO ENDIF 1123 CONTINUE ENDIF 1122 CONTINUE SEGACT,MLMOTS CALL ECROBJ('LISTMOTS',MLMOTS) RETURN ENDIF * ELSE IF (MOT_4.eq.'CENT') THEN * pour NAVIER-STOKE NLIN, extrai les POINTS CENTRES ipma = 0 c L1 = 8 n1 = 1 segini mmode1 n3 = 6 segini mchel1 n2 = 1 segini mcham1 mchel1.ichaml(1) = mcham1 ipmons = mmode1 ipchns = mchel1 do is = 1,nsous imodel = kmodel(is) if (formod(1).eq.'NAVIER_STOKES'.and.matmod(1).eq.'NLIN') & then mmode1.kmodel(1) = imodel call go2nli(ipmons,ipchns,ipres,5) if (ierr.ne.0 ) return endif if (ipma.eq.0) then ipma = ipres else call fuse(ipma,ipres,ip3,.true.) if (ierr.ne.0) return ipma = ip3 endif enddo segsup mchel1, mcham1, mmode1 if (IPMA.GT.0) then call ecrobj('MAILLAGE',ipma) return else call erreur(21) return endif ELSE MOTERR=MOT_4 CALL ERREUR(7) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | C H A R G E M E N T | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'CHARGEME') THEN CALL LIROBJ('CHARGEME',ICHAR,1,IRET) IF (IERR.NE.0) RETURN C CMOT = ' ' ICHGT = 0 LCHGT = 0 IEC = 1 CALL LIROBJ('LISTMOTS',LCHGT,0,IRET) IF (IERR.NE.0) RETURN IF (IRET.EQ.0) THEN CALL LIRCHA(CMOT,1,IRETOU) IF (IERR.NE.0) RETURN CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT) IF ((ICHGT.GE.1 .AND. ICHGT.LE.5) .OR. ICHGT.GE.9) THEN CALL LIRENT(IEC,0,IRETOU) IF (IERR.NE.0) RETURN IF (IRETOU.EQ.0) IEC = 1 ELSEIF (ICHGT.EQ.0) THEN CALL LIRCHA(MOT_4,0,IRETOU) IF (IRETOU.NE.0) THEN IF (MOT_4.EQ.'TABL') THEN ICHGT=-1 ELSE CALL REFUS ENDIF ENDIF ENDIF ENDIF C CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8) C IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1) IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2) RETURN * +-------------------------------------------------------------------+ * | | * | L I S T C H P O | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'LISTCHPO') THEN CALL LIROBJ('LISTCHPO',ILCHP1,1,IRET) IF (IERR.NE.0) RETURN CALL QUETYP(CTYP1,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL ERREUR(533) RETURN ENDIF MLCHP1 = ILCHP1 SEGACT , MLCHP1 LONCHP = MLCHP1.ICHPOI(/1) * =============================== * EXTRACTION DE PLUSIEURS INDICES * =============================== IF (CTYP1.EQ.'LISTENTI') THEN CALL LIROBJ('LISTENTI',ILENT,1,IRET) IF (IERR.NE.0) RETURN MLENTI = ILENT SEGACT,MLENTI JG = LECT(/1) N1=JG SEGINI,MLCHP2 ILCHP2= MLCHP2 DO 1211 I=1 , JG IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN INTERR(1) = LECT(I) CALL ERREUR(620) ENDIF MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I)) 1211 CONTINUE CALL ACTOBJ ('LISTCHPO',ILCHP2,0) CALL ECROBJ ('LISTCHPO',ILCHP2) RETURN * =========================== * EXTRACTION D'UN SEUL INDICE * =========================== ELSEIF (CTYP1.EQ.'ENTIER') THEN CALL LIRENT(ILENT,1,IRETOU) IF (IERR.NE.0) RETURN IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN INTERR(1)=ILENT CALL ERREUR(620) ENDIF ILCHPO = MLCHP1.ICHPOI(ILENT) CALL ACTOBJ('CHPOINT ',ILCHPO,1) CALL ECROBJ('CHPOINT ',ILCHPO) RETURN * ==================================================== * MOT-CLE "VALE" => EXTRACTION DES VALEURS EN UN POINT * ==================================================== ELSEIF (CTYP1.EQ.'MOT') THEN CALL LIRCHA(CMOT,1,IRETOU) IF (IERR.NE.0) RETURN IF (CMOT.NE.'VALE') THEN MOTERR = 'VALE' CALL ERREUR(396) RETURN ENDIF CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL LIRCHA(MOCOMP,0,IRETOU) IF (IRETOU.GT.0) THEN JGN=LOCOMP JGM=1 SEGINI,MLMOTS MOTS(1)=MOCOMP ENDIF ENDIF CALL LIROBJ('POINT',MPOINT,1,IRETOU) IF (IERR.NE.0) RETURN CALL EXTR24(MLCHP1,MLMOTS,MPOINT,MLREEL) IF (IERR.NE.0) RETURN SEGACT,MLREEL CALL ECROBJ('LISTREEL',MLREEL) RETURN * SYNTAXE INCORRECTE ELSE MOTERR(1:40) = 'ENTIER LISTENTI"VALE"' CALL ERREUR(471) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | N U A G E | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'NUAGE') THEN CALL LIROBJ('NUAGE ',IPOINT,1,IRET) CALL ACTOBJ('NUAGE ',IPOINT,1) IF (IERR.NE.0) RETURN MNUAGE=IPOINT CALL LIRMOT(NUMO,5,INU1,0) IF (INU1.EQ.0) THEN CALL LIRCHA(CTYP1,1,IRETOU) IF (IERR.NE.0) THEN RETURN ENDIF CALL LIRMOT(NUMO,5,INU1,0) IF (INU1.EQ.0) THEN IF (CTYP1.EQ.'COMP ') THEN IPROG = 1 ELSE IPOSI = 0 DO 1250 I=1,NUANOM(/2) IF (NUANOM(I).EQ.CTYP1) IPOSI=I 1250 CONTINUE IF (IPOSI.EQ.0) THEN MOTERR(1:8) = CTYP1 C TYP1 n'est pas un nom de variable du NUAGE CALL ERREUR(672) RETURN ENDIF IPROG = 2 ENDIF ELSE IPOSI = 0 DO 1251 I=1,NUANOM(/2) IF (NUANOM(I).EQ.CTYP1) IPOSI=I 1251 CONTINUE IF (IPOSI.EQ.0) THEN MOTERR(1:8) = CTYP1 C TYP1 n'est pas un nom de variable du NUAGE CALL ERREUR(672) RETURN ENDIF IPROG = 3 ENDIF ELSE CALL LIRCHA(CTYP1,1,IRETOU) IF (IERR.NE.0) RETURN IPOSI = 0 DO 1252 I=1,NUANOM(/2) IF (NUANOM(I).EQ.CTYP1) IPOSI=I 1252 CONTINUE IF (IPOSI.EQ.0) THEN MOTERR= CTYP1 C TYP1 n'est pas un nom de variable du NUAGE CALL ERREUR(672) RETURN ELSE IPROG = 3 ENDIF ENDIF C-------------- Lecture eventuelle des FLOTTANTS ------------- IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN CALL LIRREE(XVAL1,0,IRETOU) IF (IRETOU.EQ.0) THEN C Il manque la valeur de la composante reelle CALL ERREUR(668) RETURN ENDIF ELSE CALL LIRREE(XVAL1,0,IRETO1) CALL LIRREE(XVAL2,0,IRETO2) IF ((IRETO1.EQ.0).OR.(IRETO2.EQ.0)) THEN C Il faut specifier deux valeurs reelles CALL ERREUR(673) RETURN ENDIF ENDIF ENDIF C--------- Cas de l'extraction des noms des composantes du NUAGE ------- IF (IPROG.EQ.1) THEN CALL EXTR19(IPOINT,IPLSTM) IF (IPLSTM.NE.0) THEN CALL ECROBJ('LISTMOTS',IPLSTM) ENDIF C----Cas de l'extraction de l'objet correspondant a une composante --- C----------------- donnee d'un NUAGE "colonne" ----------------------- ELSEIF (IPROG.EQ.2) THEN CALL EXTR51(IPOINT,IPOSI) C---------------------------- Autres cas ------------------------------ ELSEIF (IPROG.EQ.3) THEN IF (INU1.EQ.1) THEN BORINF=.TRUE. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI) ELSEIF (INU1.EQ.2) THEN BORINF=.FALSE. CALL EXTR50(IPOINT,BORINF,XVAL1,IPOSI) ELSEIF (INU1.EQ.3) THEN MINI =.TRUE. CALL EXTR52(IPOINT,MINI,IPOSI) ELSEIF (INU1.EQ.4) THEN MINI =.FALSE. CALL EXTR52(IPOINT,MINI,IPOSI) ELSEIF (INU1.EQ.5) THEN CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI) ELSE CALL ERREUR(21) RETURN ENDIF C---------------------------- Cas non prevus --------------------------- ELSE CALL ERREUR(21) RETURN ENDIF RETURN * +-------------------------------------------------------------------+ * | | * | L I S T O B J E | * | | * +-------------------------------------------------------------------+ ELSEIF (CTYP.EQ.'LISTOBJE') THEN CALL LIROBJ('LISTOBJE',ILOBJ,1,IRET) IF (IERR.NE.0) RETURN C EXTRACTION DU TYPE DES OBJETS DE LA LISTE CALL LIRCHA(CTEXT,0,IRET) IF (IRET.NE.0) THEN IF (CTEXT(1:4).EQ.'TYPE') THEN MLOBJE = ILOBJ SEGACT,MLOBJE CTYP = TYPOBJ CALL ECRCHA(CTYP) RETURN ENDIF ENDIF C EXTRACTION D'UN OBJET DE LA LISTE CALL LIRENT(I1,1,IRET) IF (IERR.NE.0) RETURN IF (I1.LE.0) THEN CALL ERREUR(21) RETURN ENDIF MLOBJE = ILOBJ SEGACT,MLOBJE NOBJ = LISOBJ(/1) IF (I1.GT.NOBJ) THEN INTERR(1) = I1 CALL ERREUR(620) RETURN ENDIF IP1 = LISOBJ(I1) CTYP = TYPOBJ CALL ECROBJ(CTYP,IP1) RETURN C FIN IF(CTYP... ENDIF *********************************************************************** * ON TRAITE LES LISTENTI, LISTREEL ET LISTMOTS SEPAREMENT POUR * * POUVOIR TOLERER L'INVERSION DES DEUX ARGUMENTS (LA LISTE PRINCIPALE * * ET L'INDICE/LA LISTE D'INDICES) * *********************************************************************** * +-------------------------------------------------------------------+ * | | * | L I S T M O T S | * | | * +-------------------------------------------------------------------+ 10 CONTINUE CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET) IF (IRET.EQ.0) GOTO 20 MLMOT1 = ILMOT1 SEGACT , MLMOT1 LONMOT = MLMOT1.MOTS(/2) JGN = MLMOT1.MOTS(/1) * =============================== * EXTRACTION DE PLUSIEURS INDICES * =============================== CALL LIROBJ('LISTENTI',ILENT,0,IRET) IF ( IRET .EQ. 1 ) THEN MLENTI = ILENT SEGACT , MLENTI JGM = LECT(/1) SEGINI , MLMOT2 ILMOT2= MLMOT2 DO 1221 I=1 , JGM I_EXTR =LECT(I) IF (( I_EXTR .GT. LONMOT ) .OR. ( I_EXTR .LT. 1 )) THEN INTERR(1) = I_EXTR CALL ERREUR(620) ENDIF MLMOT2.MOTS(I) = MLMOT1.MOTS(I_EXTR) 1221 CONTINUE SEGACT , MLMOT2 CALL ECROBJ ('LISTMOTS',ILMOT2) RETURN * =========================== * EXTRACTION D'UN SEUL INDICE * =========================== ELSE CALL LIRENT (ILENT,1,IRETOU) IF (IERR .NE. 0) RETURN IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN INTERR(1)=ILENT CALL ERREUR(620) ELSE CTEXT = MLMOT1.MOTS(ILENT) ENDIF CALL ECRCHA(CTEXT(1:JGN)) RETURN ENDIF * +-------------------------------------------------------------------+ * | | * | L I S T R E E L | * | | * +-------------------------------------------------------------------+ 20 CONTINUE CALL LIROBJ('LISTREEL',ILREE1,0,IRET) IF (IRET.EQ.0) GOTO 30 MLREE1 = ILREE1 SEGACT , MLREE1 LONREE = MLREE1.PROG(/1) * =============================== * EXTRACTION DE PLUSIEURS INDICES * =============================== CALL LIROBJ('LISTENTI',ILENT,0,IRET) IF ( IRET .EQ. 1 ) THEN MLENTI = ILENT SEGACT , MLENTI JG = LECT(/1) SEGINI , MLREE2 ILREE2= MLREE2 DO 1231 I=1 , JG I_EXTR =LECT(I) IF (( I_EXTR .GT. LONREE ) .OR. ( I_EXTR .LT. 1 )) THEN INTERR(1) = I_EXTR CALL ERREUR(620) RETURN ENDIF MLREE2.PROG(I) = MLREE1.PROG(I_EXTR) 1231 CONTINUE SEGACT , MLREE2 CALL ECROBJ ('LISTREEL',ILREE2) RETURN * =========================== * EXTRACTION D'UN SEUL INDICE * =========================== ELSE CALL LIRENT (ILENT,1,IRETOU) IF (IERR .NE. 0) RETURN IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN INTERR(1)=ILENT CALL ERREUR(620) ELSE REELDP = MLREE1.PROG(ILENT) ENDIF CALL ECRREE(REELDP) RETURN ENDIF 124 CONTINUE * +-------------------------------------------------------------------+ * | | * | L I S T E N T I | * | | * +-------------------------------------------------------------------+ 30 CONTINUE CALL LIROBJ('LISTENTI',ILENT1,0,IRET) IF (IRET.EQ.0) GOTO 999 MLENT1 = ILENT1 SEGACT , MLENT1 LONENT = MLENT1.LECT(/1) * =============================== * EXTRACTION DE PLUSIEURS INDICES * =============================== CALL LIROBJ('LISTENTI',ILENT2,0,IRET) IF ( IRET .EQ. 1 ) THEN MLENT2 = ILENT2 SEGACT , MLENT2 JG = MLENT2.LECT(/1) SEGINI , MLENT3 ILENT3= MLENT3 DO I=1 , JG I_EXTR =MLENT2.LECT(I) IF (I_EXTR.GT.LONENT .OR. I_EXTR.LT.1) THEN INTERR(1) = I_EXTR CALL ERREUR(620) ENDIF MLENT3.LECT(I) = MLENT1.LECT(I_EXTR) ENDDO SEGACT , MLENT3 CALL ECROBJ ('LISTENTI',ILENT3) RETURN * =========================== * EXTRACTION D'UN SEUL INDICE * =========================== ELSE CALL LIRENT (ILENT,1,IRETOU) IF (IERR .NE. 0) RETURN IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN INTERR(1)=ILENT CALL ERREUR(620) ELSE INTEGR = MLENT1.LECT(ILENT) ENDIF CALL ECRENT(INTEGR) RETURN ENDIF * +-------------------------------------------------------------------+ * | 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 | * +-------------------------------------------------------------------+ 999 CONTINUE CALL ERREUR(676) END