C ***************************************************************** C Delos est un mailleur automatique "surfacique" qui genere une C triangulation pour la simulation et/ou la visualisation. C C Licence et conditions d'utilisation de Delos. C C Copyright (C) 1994-2005 ARMINES/Ecole des Mines de Paris C C Ce programme est un logiciel libre ; vous pouvez le redistribuer C et/ou le modifier conformement aux dispositions de la Licence C Publique Generale GNU, telle que publiee par la Free Software C Fondation ; version 2 de la licence, ou encore (a votre choix) C toute version ulterieure. C C Ce programme est distribue dans l'esport qu'il sera utile, mais C SANS AUCUNE GARANTIE ; sans meme la garantie implicite de C COMMERCIALISATION ou D'ADAPTATION A UN OBJET PARTICULIER. Pour C plus de detail, voir la Licence Publique Generale GNU C C Vous devez avoir recu un exemplaire de la Licence Publique C Generale en meme temps que ce programme ; si ce n'est pas le cas, C ecrivez a la Free Software Fondation Inc.,675 Mass Ave,Cambridge, C MA 02139, Etats-Unis. C C Ce logiciel est telechargeable a l'adresse : C C http://www.ensmp.fr/~stab/delos C C vous trouverez egalement, sur ce site, un mode d'emploi complet et C des informations supplementaires. C C ***************************************************************** C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_CHAINE.F C OBJET : AFFICHAGE ET SAISIE INTERACTIVE DES TYPES DE BASE. C FONCT. : C ESLCHA : ATTEND UNE CHAINE (AU CLAVIER) C ESECHA : ECRIT UNE CHAINE SUR LE STANDARD OUTPUT C ESERRO : ECRIT UN MESSAGE D'ERREUR SUR LE STANDARD OUTPUT C ESLINT : ATTEND UN OU PLUSIEURS ENTIER(S) AU CLAVIER C ESEINT : ECRIT UN OU PLUSIEURS ENTIER(S) SUR LE C STANDARD OUTPUT C ESLREA : ATTEND UN OU PLUSIEURS REEL(S) AU CLAVIER C ESEREA : ECRIT UN OU PLUSIEURS REEL(S) SUR LE C STANDARD OUTPUT C AUTEUR : O.STAB C DATE : 05.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 14.09.06, ajout messages ESMESS C ***************************************************************** C INTEGER FUNCTION ESLGCH(CHAINE) C ***************************************************************** C OBJET : RENVOI LA LONGUEUR D'UNE CHAINE C ***************************************************************** CHARACTER*(*) CHAINE C INTEGER I,J,LCH C LCH = LEN(CHAINE) J = LCH DO 10 I=1,LCH IF( CHAINE(J:J).NE.' ' )GOTO 888 J = J - 1 10 CONTINUE 888 ESLGCH = J 999 END C SUBROUTINE ESLCHA(IO,LABEL,NOM) C ***************************************************************** C OBJET : ATTEND UNE CHAINE (AU CLAVIER) C ***************************************************************** CHARACTER*(*) NOM,LABEL INTEGER IO C INTEGER ICLAV,IECR PARAMETER (ICLAV = 5, IECR = 6) INTEGER N,ESLGCH EXTERNAL ESLGCH CHARACTER*256 MESSAG C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- N = ESLGCH(LABEL) IF(N.GT.0) > WRITE ( UNIT = IECR, FMT = *,ERR=100)LABEL(:N) READ ( UNIT = ICLAV, FMT = '(A)',ERR=100,END=100) NOM ELSE IF( IO .EQ. 2 )THEN C --- LECTURE DANS UN FICHIER ESPION --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ELSE IF( IO.EQ. 3 )THEN C --- LECTURE VIA INTERFACE GRAPHIQUE --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ENDIF ENDIF ENDIF GOTO 999 C ---------- TRAITEMENT DES ERREURS ------------ 100 CONTINUE CALL ESMESS(-1,38,1,'CE N EST PAS UNE CHAINE ',MESSAG) CALL ESECHA(1,MESSAG,LABEL) 999 END C SUBROUTINE ESECHA(IO,LABEL,NOM) C ***************************************************************** C OBJET : ECRIT UNE CHAINE SUR LE STANDARD OUTPUT C ***************************************************************** CHARACTER*(*) NOM,LABEL INTEGER IO C INTEGER IECR PARAMETER (IECR = 6) INTEGER ESLGCH EXTERNAL ESLGCH CHARACTER*256 MESSAG C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- WRITE ( UNIT = IECR, FMT = *, ERR = 999) > LABEL(:ESLGCH(LABEL)),NOM(:ESLGCH(NOM)) ELSE IF( IO .EQ. 2 )THEN C --- ECRITURE DANS UN FICHIER ESPION --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ELSE IF( IO.EQ. 3 )THEN C --- AFFICHAGE VIA INTERFACE GRAPHIQUE --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ENDIF ENDIF ENDIF C 10 FORMAT(A) 999 END C C SUBROUTINE ESERRO(IO,NUM,MODULE,IMESS) C ***************************************************************** C OBJET ESERRO : ECRIT UN MESSAGE D'ERREUR POUR L'UTILISATEUR C Obsolet ? C ***************************************************************** CHARACTER*(*) IMESS,MODULE INTEGER NUM INTEGER IO C IF( NUM .EQ. -1 )THEN CALL ESECHA(IO, > '--> ERREUR : DONNEES INCORRECTES, ',MODULE) ELSE IF( NUM .EQ. -2 )THEN CALL ESECHA(IO, > '--> ERREUR : PROBLEME MEMOIRE, ',MODULE) ELSE IF( NUM .EQ. -3 )THEN CALL ESECHA(IO, > '--> ERREUR NON ENCORE IMPLEMENTE,',MODULE) ELSE IF( NUM .EQ. 0 )THEN CALL ESECHA(IO, > '--> ATTENTION,',MODULE) ELSE PRINT *,NUM ENDIF ENDIF ENDIF ENDIF CALL ESECHA(IO,IMESS,' ') END C C SUBROUTINE ESLINT(IO,LABEL,IENTIE,NBE) C ***************************************************************** C OBJET : ATTEND UN OU PLUSIEURS ENTIER(S) AU CLAVIER C ***************************************************************** CHARACTER*(*) LABEL INTEGER IO,NBE,IENTIE(*) C INTEGER ICLAV,IECR PARAMETER (ICLAV = 5, IECR = 6) INTEGER ESLGCH EXTERNAL ESLGCH C INTEGER I CHARACTER*256 MESSAG C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- WRITE ( UNIT = IECR, FMT = *) LABEL(:ESLGCH(LABEL)) READ ( UNIT = ICLAV, FMT = *,ERR = 100,END = 100) > (IENTIE(I),I=1,NBE) ELSE IF( IO .EQ. 2 )THEN C --- LECTURE DANS UN FICHIER ESPION --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ELSE IF( IO.EQ. 3 )THEN C --- LECTURE VIA INTERFACE GRAPHIQUE --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ENDIF ENDIF ENDIF GOTO 999 C ---------- TRAITEMENT DES ERREURS ------------ 100 CONTINUE CALL ESMESS(-1,39,1,'CE N EST PAS UN ENTIER ',MESSAG) CALL ESECHA(1,MESSAG,LABEL) DO 10 I=1,NBE IENTIE(I) = 0 10 CONTINUE 999 END C C SUBROUTINE ESEINT(IO,LABEL,IENTIE,NBI) C ***************************************************************** C OBJET : ECRIT UN OU PLUSIEURS ENTIER(S) SUR LE STANDARD OUTPUT C ***************************************************************** CHARACTER*(*) LABEL INTEGER IO INTEGER IENTIE(*),NBI C INTEGER IECR,J PARAMETER (IECR = 6) INTEGER ESLGCH EXTERNAL ESLGCH C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- WRITE ( UNIT = IECR, FMT = *, ERR = 999) > LABEL(:ESLGCH(LABEL)),(IENTIE(J),J=1,NBI) ELSE IF( IO .EQ. 2 )THEN C --- ECRITURE DANS UN FICHIER ESPION --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ELSE IF( IO.EQ. 3 )THEN C --- AFFICHAGE VIA INTERFACE GRAPHIQUE --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ENDIF ENDIF ENDIF 999 END C SUBROUTINE ESLREA(IO,LABEL,REEL,NBE) C ***************************************************************** C OBJET : ATTEND UN OU PLUSIEURS REEL(S) AU CLAVIER C ***************************************************************** CHARACTER*(*) LABEL INTEGER IO,NBE REAL REEL(*) C INTEGER ICLAV,IECR PARAMETER (ICLAV = 5, IECR = 6) INTEGER ESLGCH EXTERNAL ESLGCH C CHARACTER*256 MESSAG INTEGER I C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- WRITE ( UNIT = IECR, FMT = *) LABEL(:ESLGCH(LABEL)) READ ( UNIT = ICLAV, FMT = *,ERR = 100,END = 100) > (REEL(I),I=1,NBE) ELSE IF( IO .EQ. 2 )THEN C --- LECTURE DANS UN FICHIER ESPION --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ELSE IF( IO.EQ. 3 )THEN C --- LECTURE VIA INTERFACE GRAPHIQUE --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ENDIF ENDIF ENDIF GOTO 999 C ---------- TRAITEMENT DES ERREURS ------------ 100 CONTINUE CALL ESMESS(-1,39,1,'CE N EST PAS UN REEL :',MESSAG) CALL ESECHA(1,MESSAG,LABEL) DO 10 I=1,NBE REEL(I) = 0.0 10 CONTINUE 999 END C SUBROUTINE ESEREA(IO,LABEL,REEL,NBR) C ***************************************************************** C OBJET : ECRIT UN OU PLUSIEURS REEL(S) SUR LE STANDARD OUTPUT C ***************************************************************** CHARACTER*(*) LABEL INTEGER IO REAL REEL(*) INTEGER NBR C INTEGER IECR,J PARAMETER (IECR = 6) INTEGER ESLGCH EXTERNAL ESLGCH C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- WRITE ( UNIT = IECR, FMT = *, ERR = 999) > LABEL(:ESLGCH(LABEL)),(REEL(J),J=1,NBR) ELSE IF( IO .EQ. 2 )THEN C --- ECRITURE DANS UN FICHIER ESPION --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ELSE IF( IO.EQ. 3 )THEN C --- AFFICHAGE VIA INTERFACE GRAPHIQUE --- CALL ESERRE(1,-3,' ','NON ENCORE IMPLEMENTE') ENDIF ENDIF ENDIF C 999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_ERREUR.F C OBJET : GESTION DES ERREURS ET AUTRES UTILITAIRES GENERAUX C C FONCT. : C OBJET ESINIT : INITIALISATION DU MODE DE MESSAGE C OBJET ESERRE : ECRIT UN MESSAGE D'ERREUR (EN MODE DEBUG) C C REMARQUE : C chaque librairie a sa procedure d'affichage de message pour le debug C C AUTEUR : O.STAB C DATE : 02.05 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C C SUBROUTINE ESINIT(ITRACE) C ***************************************************************** C OBJET ESINIT : INITIALISATION DU MODE DEBUG SI ITRACE > 1 C ***************************************************************** INTEGER ITRACE INTEGER IMODE COMMON /MODEES/IMODE IMODE = ITRACE END C C SUBROUTINE ESERRE(IO,NUM,MODULE,MESSAG) C ***************************************************************** C OBJET ESERRE : ECRIT UN MESSAGE D'ERREUR (EN MODE DEBUG) C SUR LE STANDARD OUTPUT C ***************************************************************** CHARACTER*(*) MESSAG,MODULE INTEGER NUM INTEGER IO C INTEGER IMODE COMMON /MODEES/IMODE IF(IMODE.LT.2)GOTO 9999 C IF( NUM .EQ. -1 )THEN CALL ESECHA(IO, > 'ERR -1 DONNEES INCORRECTES DANS :',MODULE) ELSE IF( NUM .EQ. -2 )THEN CALL ESECHA(IO, > 'ERR -2 PROBLEME MEMOIRE DANS :',MODULE) ELSE IF( NUM .EQ. -3 )THEN CALL ESECHA(IO, > 'ERR -3 NON ENCORE IMPLEMENTE DANS :',MODULE) ELSE PRINT *,NUM ENDIF ENDIF ENDIF CALL ESECHA(IO,MESSAG,' ') 9999 END C C ******************************************************************* C FICHIER : ES_GRANDEUR.F C OBJET : ENTREES /SORTIES POUR DES GRANDEURS C FONCT. : C OBJET ECRGRD : ECRIT FICHIER DE GRANDEURS C OBJET LITGRD : LIT UN FICHIER DE GRANDEURS C C AUTEUR : O. STAB C DATE : 08.97 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 05.98, EXTRAIT LITDENNOD -> LITTSN C O.STAB, 09.04, Message d'erreur pour LITGRD C AUTEUR, DATE, OBJET : o.stab, 14.09.2006, ajout appel ESMESS !! C ******************************************************************* C SUBROUTINE ECRGRD(NOM,ENTETE,RTVANO,IVADIM,NBVANO,IERR) C ***************************************************************** C OBJET ECRGRD : ECRIT FICHIER DE GRANDEURS C C EN ENTREE : C NOM : NOM DU FICHIER C RTVANO : TABLEAU DES GRANDEURS C NBVANO : NOMBRE TOTAL DE GRANDEURS (I.E. NBRE DE NOEUDS) C IVADIM : DIMENSION DES GRANDEURS C C EN SORTIE : C IER=0 : PAS D'ERREUR C IER=-1 : PROBLEME D'OUVERTURE DU FICHIER C ***************************************************************** CHARACTER*(*) NOM,ENTETE INTEGER IVADIM,NBVANO REAL RTVANO(*) INTEGER IERR C INTEGER IUNIT,I,J INTEGER ESLGCH EXTERNAL ESLGCH CHARACTER*500 CHAINE INTEGER NBCHAR C si pas de nom => CLAVIER ou ECRAN IF( NOM.EQ."" )THEN IUNIT=6 ELSE CALL GESFIC('O',NOM,0,0,IUNIT,IERR) IF(IERR.NE.0)GOTO 9999 ENDIF IERR = -1 C C I. ECRITURE DES NOEUDS C ---------------------- WRITE(IUNIT,'(A)', ERR = 9999) > '* GRANDEUR 1.0.0 (12 AOUT 97)' WRITE (IUNIT,'(A,A)', ERR = 9999) > '* ',ENTETE(:ESLGCH(ENTETE)) WRITE(IUNIT,'(A)')'DEBGRD' WRITE(IUNIT,*) NBVANO, IVADIM DO 10 I=1,NBVANO WRITE(CHAINE,*) I NBCHAR = ESLGCH(CHAINE) DO 5 J=1,IVADIM WRITE(CHAINE(NBCHAR+1:),*) RTVANO((I-1)*IVADIM+J) NBCHAR = ESLGCH(CHAINE) 5 CONTINUE WRITE(UNIT = IUNIT, FMT = * ) CHAINE(:ESLGCH(CHAINE)) 10 CONTINUE WRITE( IUNIT,'(A)')'FINGRD' IERR = 0 100 IF( IUNIT.NE.6 )CALL GESFIC('F',NOM,0,0,IUNIT,IERR) 9999 END C SUBROUTINE LITGRD(IACTIO,NOM,MAXCRD,RTVANO,IVADIM,NBVANO,IERR) C ***************************************************************** C OBJET LITGRD : LIT UN FICHIER DE GRANDEURS C C EN ENTREE : C NOM : NOM DU FICHIER C C RTVANO : TABLEAU DES GRANDEURS C NBVANO : NOMBRE TOTAL DE GRANDEURS (I.E. NBRE DE NOEUDS) C IVADIM : DIMENSION DES GRANDEURS C C EN SORTIE : C IER=0 : PAS D'ERREUR C IER=-1 : PROBLEME D'OUVERTURE DU FICHIER C C ***************************************************************** CHARACTER*(*) NOM INTEGER IACTIO,MAXCRD,IVADIM,NBVANO REAL RTVANO(*) INTEGER IERR C INTEGER IN,IT,I,J INTEGER NBLC,NUM CHARACTER*256 MESSAG C CALL GESFIC('O',NOM,1,0,IN,IERR) CALL GESFIC('O',' ',2,0,IT,I) IF(IERR.NE.0.OR.I.NE.0) GOTO 908 CALL GESCOM(IN,'DEBGRD',6,'FINGRD',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)GOTO 909 C ====================================== C ---- LECTURE DES VALEURS ---------- C ====================================== REWIND IN REWIND IT READ(IT,*,ERR=910,END=910) NBVANO,IVADIM IF(NBVANO.LE.0.OR.IVADIM.LE.0) GOTO 910 C --- IL FAUT AU MOINS UN POINT ! IF(IACTIO.EQ.0) GOTO 9995 IF(MAXCRD.LE.0) GOTO 9995 IF(IVADIM*NBVANO.GT.MAXCRD) GOTO 90 DO 30 I=1,NBVANO READ(IT,*,ERR=911,END=911) NUM > ,(RTVANO(IVADIM*(NUM-1)+J),J=1,IVADIM) C ---- UN PEU TARD !!! --- IF( (IVADIM*NUM).GT.MAXCRD ) GOTO 90 30 CONTINUE GOTO 9995 C --- TRAITEMENT DES ERREURS (PROGRAMMATION) --- 80 IERR=-1 GOTO 9995 90 IERR=-2 GOTO 9995 C --------------------------------------------- C --- NOUVEAU TRAITEMENT DES ERREURS (UTILISATEUR)--- C --------------------------------------------- 908 IERR =-1 CALL ESMESS(IERR,14,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 909 CONTINUE CALL ESMESS(IERR,26,1,'DEBUT OU FIN BLOC GRD NON TROUVE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 910 IERR = -1 CALL ESMESS(IERR,27,1,'NOMBRE DE GRANDEURS OU DIM INVALID',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 911 IERR = -1 CALL ESMESS(IERR,28,1,'A LA LECTURE DE LA GRANDEUR : ',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 9995 C --- FIN --- 9995 CALL GESFIC('F',' ',0,0,IN,I) CALL GESFIC('F',' ',0,0,IT,I) 9999 END C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_MESH.F C OBJET : LECTURE ET ECRITURE D'UN MAILLAGE C FONCT. : C LITVIP : LECTURE DES BLOCS COORDONNEES ET MAILLAGE C ECRVIP : ECRITURE DES BLOCS COORDONNEES ET MAILLAGE C OBJET VIPELI : CONVERTI UN ELEMENT EN ELEMENT LINEAIRE C OBJET VIPCOD : NOMBRE DE NEOUD ET DIMENSION EN FONCTION DU CODE C OBJET CODVIP : CODE EN FONCTION DU NOMBRE DE NEOUD ET DIMENSION C C AUTEUR : S-M. TIJANI + O.STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C STAB 12.96 COPIE DE TBVTAB ET KNUTA POUR L'INDEPENDANCE DE ES C STAB 11.97 ESLIFR REMPLACE ESLIT1DFR2D C STAB 07.99 NOUVELLES PROCEDURES : VIPCOD ET VIPELI (A TESTER !!!) C EXTRACTION DE ESLIFR,ESTBVT,ESKNUT (-> ES_GEOMETRIE) C STAB 04.02 : on ne converti plus les elements !!! C STAB 09.04 : Message d'erreur pour LITVIP C STAB 10.04 : LITVIP lit le bloc ARE partiellement (pas les regions) C STAB 01.05 : LITVIP renvoi -4 si bloc ARE ! C STAB,13.07.05, Pas de warning (car ca pose des problemes dans le mode "SILENT") C AUTEUR, DATE, OBJET : o.stab, 14.09.2006, ajout appel ESMESS !! C ***************************************************************** C C SUBROUTINE LITVIP(ACTION,NOM,MAXCRD,MAXITR,MAXRMA,MAXTMA, > IDIMC,NBN,COORD,IDE,NBNMAX,NBE,ITRNOE,NMT,REFMAT,TRIMAT,IERR) C ***************************************************************** C OBJET LITVIP : LECTURE D'UN MAILLAGE AU FORMAT VIPLEF C LECTURE DES BLOCS COORDONNEES ET MAILLAGE DANS LE FICHIER NOM C DU TYPE VIPLEF3D C C EN ENTREE : C ACTION : ENTIER INDIQUANT AU S/PROGRAMME LES ENTITES A LIRE C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C MAXCRD : TAILLE MAXIMALE DU TABLEAU REEL COORD C MAXITR : TAILLE MAXIMALE DU TABLEAU ENTIER ITRNOE C MAXRMA : TAILLE MAXIMALE DU TABLEAU ENTIER REFMAT C MAXTMA : TAILLE MAXIMALE DU TABLEAU ENTIER TRIMAT C DE PLUS, SI ACTION > 0 : C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C C EN SORTIE : C IERR=0 : PAS D'ERREUR C IERR=-1 : PROBLEME D'OUVERTURE DU FICHIER C IERR=-2 : L'UN DES TABLEAUX EST TROP PETIT C IERR=-4 : fichier au format GEOMETRIE (bloc ARE) C SI ACTION = 0 (CALL LITVIP(0,'TOTO',0,0,MAXRMA,0, C IDIMC,NBN,0.,IDE,NBNMAX,NBE,0,NMT,REFMAT,0,IERR) C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBN : NOMBRE TOTAL DES POINTS (NOEUDS) C IDE : DIMENSION MAXIMALE DE LA TOPOLOGIE DES ELEMENTS C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C NBE : NOMBRE D'ELEMENTS C SI MAXRMA EST ASSEZ GRAND C NMT : NOMBRE DE MATERIAUX C LE TABLEAU REFMAT CONTIENDRA LES ENTIERS REFERENCES DES C NMT MATERIAUX. C SI ACTION = 1 C NBN : NOMBRE TOTAL DES POINTS (NOEUDS) C IDE : DIMENSION MAXIMALE DE LA TOPOLOGIE DES ELEMENTS C NBE : NOMBRE D'ELEMENTS C SI MAXCRD > 0 C LES IDIMC*NBN (OU MAXCRD) COORDONNEES SERONT MISES DANS C LE TABLEAU REEL COORD. C SI MAXITR > 0 C LES NBNMAX*NBE (OU MAXITR) NUMEROS DES NOEUDS DES ELEMENTS C SERONT MIS DANS ITRNOE. C SI MAXRMA EST ASSEZ GRAND C NMT : NOMBRE DE MATERIAUX C LE TABLEAU REFMAT CONTIENDRA LES ENTIERS REFERENCES DES C NMT MATERIAUX. C SI MAXTMA EST ASSEZ GRAND C LE TABLEAU TRIMAT SERA TEL QUE LES ELEMENTS NUMEROS 1 A C TRIMAT(1) SONT DANS LE MATERIAU 1 ET LES ELEMENTS NUMEROS C TRIMAT(I-1)+1 A TRIMAT(I) SONT DANS LE MATERIAU I (1 A NMT). C C ***************************************************************** CHARACTER*(*) NOM INTEGER ACTION,MAXCRD,MAXITR,MAXRMA,MAXTMA INTEGER IDIMC,NBN,IDE,NBNMAX,NBE,NMT,IERR REAL COORD(*) INTEGER ITRNOE(*),REFMAT(*),TRIMAT(*) C C INTEGER IN,IT,N,I,J,IEL,MM,NEL,M,IC,IM,L(27),IDEE INTEGER IN,IT,N,I,J,IEL,MM,NEL,M,IC,IM,L(527),IDEE INTEGER LENCHR,NBLC INTEGER LM INTEGER MAXCOO PARAMETER (MAXCOO=10) REAL XCOORD(MAXCOO) CHARACTER*256 MESSAG C NBE = 0 NBN = 0 IDE = 0 NMT = 0 IDEE = 0 C CALL GESFIC('O',NOM,1,0,IN,IERR) CALL GESFIC('O',' ',2,0,IT,I) IF(IERR.NE.0.OR.I.NE.0) GOTO 908 CALL GESCOM(IN,'DEBXYZ',6,'FINXYZ',6,'*',IT,NBLC,IERR) IF(IERR.NE.0) GOTO 909 REWIND IN REWIND IT C ====================================== C --- 1. LECTURE DES COORDONNEES DES POINTS --- C ====================================== READ(IT,*,ERR=910,END=910) NBN,N IF(NBN.LE.0.OR.N.LE.0)GOTO 910 IF(N.GT.MAXCOO) GOTO 920 C --- IL FAUT AU MOINS UN POINT ! IF(ACTION.EQ.0) THEN IDIMC=N GOTO 35 ENDIF IF(MAXCRD.LE.0) GOTO 35 C --- erreur a l'appel : Pb de programmation en amont ! IF(N.GT.IDIMC) GOTO 80 IF(IDIMC*NBN.GT.MAXCRD) GOTO 90 C --- on verifie les coordonnees meme si ACTION=0---- ajout 10.11.2004. OStab DO 30 I=1,NBN READ(IT,*,ERR=911,END=911) (XCOORD(J),J=1,MIN(N,MAXCOO)) IF(MAXCRD.GT.0)THEN DO 20 J=1,N COORD(IDIMC*(I-1)+J)=XCOORD(J) 20 CONTINUE ENDIF 30 CONTINUE 35 REWIND IT C ====================================== C --- 2. PRELECTURE DES MAILLES --- C ====================================== C --- MODIF O.STAB 24.05.95 : PAS D'ELEMENTS N'EST PAS UNE ERREUR CALL GESCOM(IN,'DEBILM',6,'FINILM',6,'*',IT,NBLC,IERR) C ---- ajout 10.11.2004. OStab IF(IERR.NE.0) THEN IERR = 0 REWIND IT REWIND IN C --- ON ESSAYE LE BLOC ARE ----- CALL GESCOM(IN,'DEBARE',6,'FINARE',6,'*',IT,NBLC,IERR) C --- PAS D'ELEMENTS N'EST PAR UNE ERREUR BUG-18 ----- IF(IERR.NE.0)THEN NBNMAX = 0 NMT = 0 GOTO 917 ENDIF C --- on sort sans message pour pouvoir reprendre la lecture (si NEL!=0 REWIND IT READ(IT,*,ERR=912,END=912) NEL IF(NEL.NE.0)IERR =-4 GOTO 9995 ENDIF REWIND IT C --- PRELECTURE DES MAILLES --- C ====================================== READ(IT,*,ERR=912,END=912) NEL C --- MODIF O.STAB 24.05.95 : PAS D'ELEMENTS N'EST PAS UNE ERREUR IF(NEL.LE.0)THEN NBNMAX = 0 NMT = 0 GOTO 918 ENDIF MM=0 DO 60 IEL=1,NEL READ(IT,*,ERR=913,END=913) M,(L(J),J=1,MIN(M,527)),IC,IM IF ( M.GT.527 )GOTO 914 C --- on peut verifier que 0 CALL VDENTI(1,M,L,ITRNOE(NBNMAX*(J-1)+1)) 70 CONTINUE GOTO 9995 C --- TRAITEMENT DES ERREURS (PROGRAMMATION) --- 80 IERR=-1 GOTO 9995 90 IERR=-2 GOTO 9995 C --------------------------------------------- C --- NOUVEAU TRAITEMENT DES ERREURS (UTILISATEUR)--- C --------------------------------------------- 908 IERR =-1 CALL ESMESS(IERR,14,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 909 CONTINUE CALL ESMESS(IERR,15,1,'DEBUT, FIN DU BLOC XYZ NON TROUVE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 910 IERR = -1 CALL ESMESS(IERR,16,1,'NOMBRE DE POINTS OU DIM INVALIDE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 911 IERR = -1 CALL ESMESS(IERR,17,1,'A LA LECTURE DU POINT : ',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 9995 912 IERR = -1 CALL ESMESS(IERR,29,1,'NOMBRE D ELEMENTS OU DIM INVALIDE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 913 IERR = -1 CALL ESMESS(IERR,30,1,'A LA LECTURE DE L ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,IEL,1) GOTO 9995 914 IERR = -2 CALL ESMESS(IERR,31,1,'TROP DE POINTS DANS ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,527,1) GOTO 9995 915 CONTINUE CALL ESMESS(IERR,64,1,'CODE DE L ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,IC,1) CALL ESMESS(IERR,30,1,'A LA LECTURE DE L ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,IEL,1) GOTO 9995 916 IERR = -1 CALL ESMESS(IERR,32,1,' DIM ELEMENT > DIM ESPACE !',MESSAG) CALL ESEINT(1,MESSAG,IEL,1) GOTO 9995 917 IERR = 0 C CALL ESERRO(1,IERR,'BLOC ILM OU ARE', C > 'LABEL DE DEBUT OU DE FIN ABSENT') GOTO 9995 918 IERR = 0 C CALL ESERRO(1,IERR,'BLOC ILM OU ARE','ATTENTION PAS D ARETE') GOTO 9995 919 IERR= -1 C IF( L(J).GT.NBN.OR.L(J).LT.0 )GOTO 920 CALL ESMESS(IERR,61,1,'REFERENCE NOEUD INCORRECT ',MESSAG) CALL ESEINT(1,MESSAG,L(J),1) CALL ESMESS(IERR,30,1,'A LA LECTURE DE L ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,IEL,1) GOTO 9995 920 IERR = -2 CALL ESMESS(IERR,22,1,'BLOC XYZ DIMENSION TROP ELEVEE',MESSAG) CALL ESEINT(1,MESSAG,MAXCOO,1) GOTO 9995 C --- FIN --- 9995 CALL GESFIC('F',' ',0,0,IN,I) CALL GESFIC('F',' ',0,0,IT,I) 9999 END C C SUBROUTINE VIPELI(NCODE,IDE,ITRNOE,NBNE,IERR) C ***************************************************************** C OBJET VIPELI : CONVERTI UN ELEMENT EN ELEMENT LINEAIRE C EN ENTREE : C NCODE : LE CODE DE L'ELEMENT C EN SORTIE : C ITRNOE,NBNE : MODIFIES C ***************************************************************** INTEGER NCODE,IDE,ITRNOE(*),NBNE,IERR C IF(NCODE.EQ.1) NBNE=2 IF(NCODE.EQ.2) THEN NBNE=2 ITRNOE(2)=ITRNOE(3) ENDIF IF(NCODE.EQ.3) NBNE=3 IF(NCODE.EQ.4) THEN NBNE=3 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ENDIF IF(NCODE.EQ.5) NBNE=4 IF(NCODE.EQ.6) THEN NBNE=4 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(4) ITRNOE(4)=ITRNOE(6) ENDIF IF(NCODE.EQ.7.OR.NCODE.EQ.8) THEN NBNE=4 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(7) ENDIF IF(NCODE.EQ.9) NBNE=4 IF(NCODE.EQ.10) THEN NBNE=4 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(10) ENDIF IF(NCODE.EQ.11) NBNE=6 IF(NCODE.EQ.12) THEN NBNE=6 ITRNOE(4)=ITRNOE(7) ITRNOE(5)=ITRNOE(8) ITRNOE(6)=ITRNOE(9) ENDIF IF(NCODE.EQ.13) THEN NBNE=6 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(7) ITRNOE(5)=ITRNOE(9) ITRNOE(6)=ITRNOE(11) ENDIF IF(NCODE.EQ.14) THEN NBNE=6 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(10) ITRNOE(5)=ITRNOE(12) ITRNOE(6)=ITRNOE(14) ENDIF IF(NCODE.EQ.15) THEN NBNE=6 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(13) ITRNOE(5)=ITRNOE(15) ITRNOE(6)=ITRNOE(17) ENDIF IF(NCODE.EQ.16) NBNE=8 IF(NCODE.EQ.17) THEN NBNE=8 ITRNOE(5)=ITRNOE(9) ITRNOE(6)=ITRNOE(10) ITRNOE(7)=ITRNOE(11) ITRNOE(8)=ITRNOE(12) ENDIF IF(NCODE.EQ.18) THEN NBNE=8 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(7) ITRNOE(5)=ITRNOE(9) ITRNOE(6)=ITRNOE(11) ITRNOE(7)=ITRNOE(13) ITRNOE(8)=ITRNOE(15) ENDIF IF(NCODE.EQ.19) THEN NBNE=8 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(7) ITRNOE(5)=ITRNOE(10) ITRNOE(6)=ITRNOE(12) ITRNOE(7)=ITRNOE(14) ITRNOE(8)=ITRNOE(16) ENDIF IF(NCODE.EQ.20) THEN NBNE=8 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(7) ITRNOE(5)=ITRNOE(13) ITRNOE(6)=ITRNOE(15) ITRNOE(7)=ITRNOE(17) ITRNOE(8)=ITRNOE(19) ENDIF IF(NCODE.EQ.21) THEN NBNE=8 ITRNOE(2)=ITRNOE(3) ITRNOE(3)=ITRNOE(5) ITRNOE(4)=ITRNOE(7) ITRNOE(5)=ITRNOE(19) ITRNOE(6)=ITRNOE(21) ITRNOE(7)=ITRNOE(23) ITRNOE(8)=ITRNOE(25) ENDIF 9999 END C SUBROUTINE VIPCOD(NCODE,IDE,NBNE,IERR) C ***************************************************************** C OBJET VIPCOD : NOMBRE DE NOEUD ET DIMENSION EN FONCTION DU CODE C ***************************************************************** INTEGER NCODE INTEGER IDE,NBNE,IERR C IDE = 0 IERR = 0 NBNE = 0 IF(NCODE.GE.100) THEN IERR = -1 IDE = 1 C ---- les aretes ---- IF(NCODE.EQ.100)THEN NBNE=2 IERR = 0 ENDIF C ---- les polylignes ---- IF(NCODE.EQ.103)THEN NBNE=-1 IERR = 0 ENDIF C ---- les polygones ---- IF(NCODE.EQ.102) THEN NBNE=-1 IDE = 2 IERR = 0 ENDIF C ---- les sommets isoles ---- IF(NCODE.EQ.101) THEN NBNE= 1 IDE = 0 IERR = 0 ENDIF GOTO 9999 ENDIF IF(NCODE.GT.21) NCODE=NCODE-21 IF(NCODE.LT.1.OR.NCODE.GT.21) GOTO 60 IF(NCODE.GE.1.AND.NCODE.LE.2) IDE=MAX(IDE,1) IF(NCODE.GE.3.AND.NCODE.LE.8) IDE=MAX(IDE,2) IF(NCODE.GE.9) IDE=MAX(IDE,3) IF(NCODE.LE.2) NBNE=2 IF(NCODE.GE.3.AND.NCODE.LE.4) NBNE=3 IF(NCODE.GE.5.AND.NCODE.LE.8) NBNE=4 IF(NCODE.GE.9.AND.NCODE.LE.10) NBNE=4 IF(NCODE.GE.11.AND.NCODE.LE.15) NBNE=6 IF(NCODE.GE.16) NBNE=8 GOTO 9999 60 CONTINUE IERR = -1 9999 END C SUBROUTINE CODVIP(IDE,NBNMAX,ITRNOE,NCODE,NBNE,IERR) C ***************************************************************** C OBJET CODVIP : CODE EN FONCTION DU NOMBRE DE NEOUD ET DIMENSION C PB : il y a un probleme pour IDE=1 et NBNE=3 : comment distinguer C un element quadratique d'une polyligne. C ***************************************************************** INTEGER IDE,NBNMAX,ITRNOE(*) INTEGER NCODE,NBNE,IERR C NBNE = NBNMAX NCODE = -1 10 IF(ITRNOE(NBNE).EQ.0)THEN NBNE = NBNE - 1 IF(NBNE.EQ.0)THEN NCODE = -1 IERR = -1 GOTO 9999 ENDIF GOTO 10 ENDIF C GOTO( 11,12,13,14 ) (IDE+1) NCODE = -1 IERR = -1 GOTO 9999 C --- CAS 0D --- IF(NBNE.EQ.1)NCODE = 101 11 GOTO 9999 C --- CAS 1D --- C 12 NBNE = 2 C NCODE = 1 C --- modif 03.04.02 remplace par : 12 IF(NBNE.EQ.2)NCODE = 1 IF(NBNE.EQ.3)NCODE = 2 IF(NBNE.GT.3)NCODE = 102 GOTO 9999 C --- CAS 2D --- 13 NBNE = NBNMAX IF(NBNE.EQ.3)NCODE = 3 IF(NBNE.EQ.4)NCODE = 5 GOTO 9999 C --- CAS 3D --- 14 NBNE = NBNMAX IF( NBNE.EQ.4 )NCODE = 9 IF( NBNE.EQ.6 )NCODE = 11 IF( NBNE.EQ.8 )NCODE = 16 C 9999 END SUBROUTINE ECRVIP(ACTION,NOM, > IDIMC,NBN,COORD,IDE,NBNMAX,NBE,ITRNOE,NMT,REFMAT,TRIMAT,IERR) C ***************************************************************** C OBJET ECRVIP : ecriture des fichiers maillage au format VIPLEF C LECTURE DES BLOCS COORDONNEES ET MAILLAGE DANS LE FICHIER NOM C DU TYPE VIPLEF3D C C EN ENTREE : C ACTION : C ACTION=1 : ecriture d'un nouveau fichier C ACTION=2 : ecriture d'un nouveau fichier ou ecrasement d'un fichier existant C ACTION=3 : concatenation en fin d'un fichier existant C C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBN : NOMBRE TOTAL DES POINTS (NOEUDS) C IDE : DIMENSION MAXIMALE DE LA TOPOLOGIE DES ELEMENTS C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C NBE : NOMBRE D'ELEMENTS C NMT : NOMBRE DE MATERIAUX C SI NMT = 0 ALORS LE MATERIAU DE TOUS LES ELEMENTS C EST FIXE A 1 C REFMAT : LE TABLEAU REFMAT CONTIENDRA LES ENTIERS REFERENCES DES C NMT MATERIAUX. C TRIMAT : LE TABLEAU TRIMAT SERA TEL QUE TRIMAT(I) EST LE NOMBRE C D'ELEMENTS DU MATERIAU REFMAT(I) (1 A NMT). C COORD : LE TABLEAU REEL COORD. C ITRNOE : TABLEAU DES ELEMENTS C C EN SORTIE : C IER=0 : PAS D'ERREUR C IER=-1 : PROBLEME D'OUVERTURE DU FICHIER C IER=-2 : L'UN DES TABLEAUX EST TROP PETIT C C ***************************************************************** CHARACTER*(*) NOM INTEGER ACTION INTEGER IDIMC,NBN,IDE,NBNMAX,NBE,NMT,IERR REAL COORD(*) INTEGER ITRNOE(*),REFMAT(*),TRIMAT(*) C INTEGER IUNIT,I,J,K INTEGER NBNE,NCODE,NMAT,IMATD,IMATF CHARACTER*256 MESSAG C GOTO (1,2,3) ACTION 1 CONTINUE C --- Creation d'un nouveau fichier CALL GESFIC('O',NOM,0,0,IUNIT,IERR) IF(IERR.NE.0)GOTO 901 GOTO 9 2 CONTINUE C --- ecriture d'un nouveau fichier ou ecrasement d'un fichier existant CALL GESFIC('O',NOM,3,0,IUNIT,IERR) IF(IERR.NE.0)GOTO 902 GOTO 9 3 CONTINUE C --- concatenation en fin d'un fichier existant IERR = -3 GOTO 904 9 CONTINUE C C I. ECRITURE DES NOEUDS C ---------------------- WRITE(IUNIT,'(A)')'DEBXYZ' WRITE(IUNIT,*) NBN, IDIMC DO 10 I=1,NBN WRITE(IUNIT,*) (COORD((I-1)*IDIMC+J),J=1,IDIMC) 10 CONTINUE WRITE( IUNIT,'(A)')'FINXYZ' C C I. ECRITURE DES ELEMENTS C ------------------------ IF( NBE .EQ. 0 )GOTO 100 WRITE(IUNIT,'(A)')'DEBILM' WRITE(IUNIT,*) NBE C IF(NMT.LT.1)THEN NMAT = 1 DO 70 J=1,NBE CALL CODVIP(IDE,NBNMAX,ITRNOE((J-1)*NBNMAX+1),NCODE,NBNE,IERR) C MODIF 27.10.98 LE FORMAT LIBRE POSE DES PROBLEMES CAR SUR L'O2 C LA LIGNE NE CONTIENT ALORS QUE 73 CARACTERES... IF(IERR.NE.0)GOTO 903 WRITE(UNIT=IUNIT,FMT='(11I10)')NBNE, > (ITRNOE((J-1)*NBNMAX+K),K=1,NBNE), > NCODE,NMAT 70 CONTINUE ELSE C C --- LES MATERIAUX SONT DEFINIS --- IMATD = 1 DO 90 I=1,NMT NMAT = REFMAT(I) IMATF = TRIMAT(I) DO 80 J=IMATD,IMATF CALL CODVIP(IDE,NBNMAX,ITRNOE((J-1)*NBNMAX+1),NCODE,NBNE,IERR) IF(IERR.NE.0)GOTO 903 WRITE(UNIT=IUNIT,FMT='(11I10)')NBNE, > (ITRNOE((J-1)*NBNMAX+K),K=1,NBNE), > NCODE,NMAT 80 CONTINUE IMATD = IMATF + 1 90 CONTINUE ENDIF WRITE( IUNIT,'(A)')'FINILM' C 100 CALL GESFIC('F',NOM,0,0,IUNIT,IERR) GOTO 9999 c ----------- messages d'erreur -------------- 901 CONTINUE CALL ESMESS(IERR,23,1,'ATTENTION LE FICHIER EXISTE DEJA',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 902 CONTINUE CALL ESMESS(IERR,24,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 903 CONTINUE CALL ESMESS(IERR,25,1,'A L ECRITURE D UN ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,J,1) CALL GESFIC('F',NOM,0,0,IUNIT,IERR) GOTO 9999 904 CONTINUE CALL ESMESS(IERR,1,1,'PAS ENCORE IMPLEMENT',MESSAG) CALL ESECHA(1,MESSAG,' ') 9999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_GEOMETRIE.F C OBJET : LECTURE DE LA FRONTIERE D'UN DOMAINE MULTI-REGION C (BREP) C FONCT. : C OBJET LITFRT : LECTURE DE LA FRONTIERE D'UN DOMAINE A MAILLER C OBJET ESLIFR : LIT UN MAILLAGE FRONTIERE (DU MAILLAGE A CALCULER) C OBJET ESTBVT: RENVOI LES VALEURS DISTINCTES D'UN TABLEAU, C OBJET ESKNUT : TRI UN TABLEAU D'ENTIERS DANS L'ORDRE CROISSANT C AUTEUR : O.STAB C DATE : 21.07.99 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 8/4/2002,remp. de DSERRE par ESERRO C O.STAB,09.04, Message d'erreur pour LITFRT C O.STAB,04.11.04, BUG LITFRT quand pas d'elements C O.STAB,07.01.05, nouveau format d'arete LITGEO C O.STAB,25.05.05, BUG LITFRT quand ITYPE=99 (sommets isoles) C O.STAB,10.06.05, message d'erreur element contenant mauvaises C reference au point C O.STAB,13.07.05, Pas de warning (car ca pose des problemes dans C le mode "SILENT") C AUTEUR, DATE, OBJET : o.stab, 14.09.2006, ajout appel ESMESS !! C O.STAB,25.11.11, MAXNOD=10000 dans LITARE (pour SCILAB) C C ***************************************************************** C SUBROUTINE LITGEO(IT,IDE,INODES,MAXNOD,M,IREGIO,MAXREG,MR,IC,IERR) C ***************************************************************** C OBJET LITGEO : LECTURE D'UNE GEOMETRIE FILAIRE (LIGNE,...) C EN ENTREE : C IT : l'identifiant du fichier C MAXNODE, MAXREG : taille des tableaux INODES et IREGIO C EN SORTIE : C IDE : la dimension de la maille C INODES(M) : tableau contenant les noeuds (ou points de la ligne) C IREGIO(MR) : tableau contenant les regions incidentes a la ligne C IC : le type de ligne : C 99 : noeuds isoles C 100 : noeuds connectes lineairement = ligne brisee C 101 : 3 noeuds connectes par un arc C ***************************************************************** INTEGER IT INTEGER IDE,INODES(*),MAXNOD,M,IREGIO(*),MAXREG,MR,IC,IERR C INTEGER I,J,IDEBUT,IFIN,IPAS,INUM CHARACTER*256 MESSAG C READ(IT,*,ERR=901,END=902)M,(INODES(J),J=1,MIN(ABS(M),MAXNOD)),IC, > MR,(IREGIO(J),J=1,MIN(MR,MAXREG)) C ---- VERIFICATION ---- IDE = 0 IF(MR.GT.10)GOTO 903 IF(M.GT.MAXNOD)GOTO 904 C ---- LISTE DES NOEUDS ---- C --- si M positif : c'est directement la liste des noeuds C --- si M negatif : c'est un intervalle IF( M.LT.0 )THEN IF( M.NE.-3 )GOTO 908 IDEBUT = INODES(1) IFIN = INODES(2) IPAS = INODES(3) M = 0 DO 5 INUM=IDEBUT,IFIN,IPAS M = M + 1 IF(M.GT.MAXNOD)GOTO 904 INODES(M)=INUM 5 CONTINUE IF( M.EQ.0 )GOTO 909 ENDIF C ---- INTERPOLATION ENTRE LES NOEUDS ---- GOTO(10,20,30) IC-98 GOTO 905 C --- un sommet isole : 99 --- 10 CONTINUE IF(M.LT.1)GOTO 906 IF(MR.GT.1)GOTO 906 IDE = 0 GOTO 100 C --- une arete ou une polyligne : 100 --- 20 CONTINUE IF(M.LT.2)GOTO 906 IDE = 1 GOTO 100 C --- un arc de cercle : 101 --- 30 CONTINUE IF(M.NE.3)GOTO 906 GOTO 100 C ---- COPIE DES ELEMENTS ---- 100 CONTINUE GOTO 9999 C ----------------------- C --- TRAITEMENT DES ERREURS --- C ----------------------- 901 IERR=-1 CALL ESMESS(IERR,2,1,' LECTURE D UNE FRONTIERE',MESSAG) CALL ESECHA(1,MESSAG,' ') c > 'ENREGISTREMENTS INCORRECT') GOTO 9999 902 IERR=-1 CALL ESMESS(IERR,3,1,'DEFINITION FRONTIERE INCOMPLETE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9999 903 IERR=-2 CALL ESMESS(IERR,4,1,'TROP DE REGIONS SUR UNE FRONTIERE >',MESSAG) CALL ESEINT(1,MESSAG,MAXREG,1) GOTO 9999 904 IERR=-1 CALL ESMESS(IERR,5,1,'TROP DE NOEUDS SUR UNE FRONTIERE >',MESSAG) CALL ESEINT(1,MESSAG,MAXNOD,1) GOTO 9999 905 IERR=-1 CALL ESMESS(IERR,6,1,'CODE DE FRONTIERE INCONNU :',MESSAG) CALL ESEINT(1,MESSAG,IC,1) GOTO 9999 906 IERR=-1 CALL ESMESS(IERR,7,1,'NOMBRE DE NOEUDS INCORRECT :',MESSAG) CALL ESEINT(1,MESSAG,M,1) GOTO 9999 907 IERR=-1 CALL ESMESS(IERR,8,1,'NOMBRE DE REGION INCORRECT:',MESSAG) CALL ESEINT(1,MESSAG,MR,1) GOTO 9999 908 IERR=-1 CALL ESMESS(IERR,9,1,'CODE D INTERVALLE INCORRECT (-3):',MESSAG) CALL ESEINT(1,MESSAG,M,1) GOTO 9999 909 IERR=-1 CALL ESMESS(IERR,10,1,'L INTERVAL EST VIDE :',MESSAG) CALL ESEINT(1,MESSAG,M,1) GOTO 9999 C 9999 END C SUBROUTINE LITARE(IT,IDE,IORIG,IEXTR,M,IREGIO,MR,IERR) C ***************************************************************** C OBJET LITARE : LECTURE D'UNE ARETE C ***************************************************************** INTEGER IT INTEGER IDE,IORIG,IEXTR,M,IREGIO(*),MR,IERR C C --- CODE POUR LES ELEMENTS DE TYPE : ARETE DE FRONTIERE INTEGER MAXNOD,MAXREG C PARAMETER (MAXNOD=27,MAXREG=10) C OS. 11.2011 : MAXNOD >> 27 avec des genrateurs (comme SCILAB) PARAMETER (MAXNOD=10000,MAXREG=10) INTEGER L(MAXNOD),LR(MAXREG),I,J,IC INTEGER CODARE PARAMETER (CODARE = 100) CHARACTER*256 MESSAG C READ(IT,*,ERR=901,END=902) M, ( L(J),J=1,MIN(M ,MAXNOD)),IC, > MR,(LR(J),J=1,MIN(MR,MAXREG)) C ---- VERIFICATION ---- IDE = 0 IF(MR.GT.10)GOTO 903 IF((IC.NE.CODARE).OR.(M.NE.2))GOTO 904 C ---- COPIE DES ELEMENTS ---- IDE = 1 IORIG = L(1) IEXTR = L(2) DO 20 J=1,MR IREGIO(J)=LR(J) 20 CONTINUE GOTO 9999 C ----------------------- C --- TRAITEMENT DES ERREURS --- C ----------------------- 901 IERR=-1 CALL ESMESS(IERR,2,1,'LECTURE D UNE FRONTIERE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9999 902 IERR=-1 CALL ESMESS(IERR,3,1,'DEFINITION FRONTIERE INCOMPLETE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9999 903 IERR=-2 CALL ESMESS(IERR,4,1,'TROP DE REGION SUR LA FRONTIERE >',MESSAG) CALL ESEINT(1,MESSAG,MAXREG,1) GOTO 9999 904 IERR=-1 CALL ESMESS(IERR,7,1,'NOMBRE DE NOEUDS INCORRECT !',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9999 9999 END C C SUBROUTINE LITFRT(ACTION,NOM,MAXCRD,MAXITR,MAXRMA,MAXTMA, > IDIMC,NBN,COORD,IDE,NBNMAX,NBE,ITRNOE, > NMT,REFMAT,NBRMAX,TRIMAT,IERR) C ***************************************************************** C OBJET LITFRT : LECTURE DE LA FRONTIERE D'UN DOMAINE A MAILLER C IDEM DS1 MAIS TRIMAT N'EST PLUS LES INTERVALS : C C'EST DIRECTEMENT LES REFERENCES DES ELEMENTS ! C EN ENTREE : C ACTION : ENTIER INDIQUANT AU S/PROGRAMME LES ENTITES A LIRE C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C MAXCRD : TAILLE MAXIMALE DU TABLEAU REEL COORD C MAXITR : TAILLE MAXIMALE DU TABLEAU ENTIER ITRNOE C MAXRMA : TAILLE MAXIMALE DU TABLEAU ENTIER REFMAT C MAXTMA : TAILLE MAXIMALE DU TABLEAU ENTIER TRIMAT C DE PLUS, SI ACTION > 0 : C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C NBRMAX : NOMBRE MAXIMAL DE REGIONS PAR ELEMENT C C EN SORTIE : C IERR=0 : PAS D'ERREUR C IERR=-1 : PROBLEME D'OUVERTURE DU FICHIER C IERR=-2 : L'UN DES TABLEAUX EST TROP PETIT C ---- LES DIMENSIONS DU MAILLAGE --- C SI ACTION = 0 C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBN : NOMBRE TOTAL DES POINTS (NOEUDS) C IDE : DIMENSION MAXIMALE DE LA TOPOLOGIE DES ELEMENTS C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C NBE : NOMBRE D'ELEMENTS C NBRMAX : NOMBRE MAXIMAL DE REGIONS PAR ELEMENT C SI MAXRMA EST ASSEZ GRAND C NMT : NOMBRE DE REGIONS (DE FACES) C LE TABLEAU REFMAT CONTIENDRA LES ENTIERS REFERENCES DES C NMT FACES. C C SI ACTION = 1 C COORD : SI MAXCRD > 0 C LES IDIMC*NBN (OU MAXCRD) COORDONNEES SERONT MISES DANS C LE TABLEAU REEL COORD. C C ITRNOE : SI MAXITR > 0 C LES NBNMAX*NBE (OU MAXITR) NUMEROS DES NOEUDS DES ELEMENTS C SERONT MIS DANS ITRNOE. C C NMT,REFMAT,TRIMAT: C NMT : NOMBRE DE REGIONS (DE FACE EN 3D) C REFMAT: SI MAXRMA EST ASSEZ GRAND C CONTIENDRA LES ENTIERS REFERENCES DES NMT REGIONS. C C NBRMAX : NOMBRE MAXIMUM DE REGIONS INCIDENTES A UNE ARETE C TRIMAT : SI MAXTMA EST ASSEZ GRAND C LES NBRMAX*NBE REFERNCES ASSOCIEES AUX ELEMENTS C C REMARQUES TRIMAT : C 1. CAS 2D MONO-POLYGONE (NBRMAX =1) C FRONTIERES REELLES (VIDE/PLEIN) C TRIMAT() = (0,+I) OU (+I,0) OU (I) C C 2. CAS 2D MULTI-POLYGONE OU 3D MONO-POLYEDRE (NBRMAX=2) C FRONTIERES INTER-MATERIAUX (MATI/MATJ) C TRIMAT() = (+I,+J) C MATERIAU A DROITE ET A GAUCHE DES ARETES FRONTIERES C (TRIMAT((I-1)*2+1),TRIMAT((I-1)*2+2)) I EST LE NUMERO DE L'ELEMENT C C 3. CAS 3D MULTI-POLYEDRES (NBRMAX > 2) C FRONTIERE INTER-MATERIAUX (MAT1/MAT2/MAT3...) C TRIMAT() = (+I,J,K,...) C ON TOURNE DANS LE SENS DIRECT AUTOUR DE L'ARETE C C (OBSOLET ? UN MATERIAU INCONNU = -1) C C ***************************************************************** CHARACTER*(*) NOM INTEGER ACTION,MAXCRD,MAXITR,MAXRMA,MAXTMA INTEGER IDIMC,NBN,IDE,NBNMAX,NBE,NMT,NBRMAX,IERR REAL COORD(*) INTEGER ITRNOE(*),REFMAT(*),TRIMAT(*) C INTEGER MAXREG,MAXCOO,MAXNOD PARAMETER (MAXREG=10,MAXCOO=10,MAXNOD=10000) INTEGER IN,IT,N,I,J,IEL,NEL,M,MM,MR,MMR INTEGER ISEG,INOD,IDEE INTEGER INODES(MAXNOD),IREGIO(MAXREG),ITYPE INTEGER NBLC REAL XCOORD(MAXCOO) CHARACTER*256 MESSAG C --- le test de la memoire : IF(MAXRMA.GT.0)REFMAT(MAXRMA) = 0 IF(MAXTMA.GT.0)TRIMAT(MAXTMA) = 0 IF(MAXITR.GT.0)ITRNOE(MAXITR) = 0 C IERR = 0 NBE = 0 NBN = 0 IDE = 0 NMT = 0 IDEE = 0 IF(ACTION.LE.0) THEN IDIMC = 0 NBNMAX = 0 NBRMAX = 0 ENDIF C CALL GESFIC('O',NOM,1,0,IN,IERR) CALL GESFIC('O',' ',2,0,IT,I) IF(IERR.NE.0.OR.I.NE.0) GOTO 908 C ====================================== C --- 1. BLOC DES COORDONNEES DES POINTS --- C ====================================== CALL GESCOM(IN,'DEBXYZ',6,'FINXYZ',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)GOTO 909 REWIND IN REWIND IT C --- LECTURE DES COORDONNEES DES POINTS --- C ====================================== READ(IT,*,ERR=910,END=910) NBN,N IF(NBN.LE.0.OR.N.LE.0) GOTO 910 IF(N.GT.MAXCOO) GOTO 920 C --- IL FAUT AU MOINS UN POINT ! IF(ACTION.EQ.0) THEN IDIMC=N ELSE IF(MAXCRD.GT.0)THEN IF(N.GT.IDIMC) GOTO 906 IF(IDIMC*NBN.GT.MAXCRD) GOTO 907 ENDIF ENDIF C --- on verifie les coordonnees meme si ACTION=0 DO 30 I=1,NBN READ(IT,*,ERR=911,END=911) (XCOORD(J),J=1,MIN(N,MAXCOO)) IF(MAXCRD.GT.0)THEN DO 20 J=1,N COORD(IDIMC*(I-1)+J)=XCOORD(J) 20 CONTINUE ENDIF 30 CONTINUE REWIND IT C ====================================== C --- 2. BLOC DES MAILLES --- C ====================================== C --- MODIF O.STAB 24.05.95 : PAS D'ELEMENTS N'EST PAS UNE ERREUR REWIND IN CALL GESCOM(IN,'DEBILM',6,'FINILM',6,'*',IT,NBLC,IERR) C PRINT *,'NBLC DS DEBILM: ',NBLC IF(IERR.NE.0) THEN IERR = 0 REWIND IT REWIND IN C --- ON ESSAYE LE BLOC ARE ----- CALL GESCOM(IN,'DEBARE',6,'FINARE',6,'*',IT,NBLC,IERR) C --- PAS D'ELEMENTS N'EST -A PRIORI- PAR UNE ERREUR BUG-18 ----- IF(IERR.NE.0)THEN NBNMAX = 0 NBRMAX = 0 GOTO 917 ENDIF ENDIF REWIND IT C --- PRELECTURE DES ARETES --- C ====================================== READ(IT,*,ERR=912,END=912) NEL IF(NEL.LE.0)THEN NBNMAX = 0 NBRMAX = 0 GOTO 918 ENDIF MM=0 MMR = 0 NBE = 0 DO 66 IEL=1,NEL C CALL LITARE(IT,IDEE,IORIG,IEXTR,M,IREGIO,MR,IERR) CALL LITGEO(IT,IDEE,INODES,MAXNOD,M,IREGIO,MAXREG,MR,ITYPE,IERR) IF(IERR.NE.0)GOTO 913 C --- on verifie que tout les noeuds sont corrects : DO 45 INOD=1,M IF((INODES(INOD).GT.NBN).OR.(INODES(INOD).LT.1))GOTO 914 45 CONTINUE C --- pour les sommets isoles IF(M.EQ.1)NBE=NBE+1 C --- pour les polylignes et ensemble de noeuds isoles ! BUG O.Stab 26.05.05 IF(M.GT.1)THEN IF(ITYPE.EQ.99)NBE=NBE+M IF(ITYPE.EQ.100)NBE=NBE+(M-1) ENDIF C IF(IDEE.GT.IDIMC)GOTO 916 IDE=MAX(IDE,IDEE) IF( ITYPE.EQ.100 )THEN MM=MAX(MM,2) ELSE IF( ITYPE.EQ.99 )THEN MM=MAX(MM,1) ELSE MM=MAX(MM,M) ENDIF ENDIF MMR=MAX(MMR,MR) C --- ON COMPTE LES REGIONS (LES FACES EN 3D) C --- ON COMPARE IRGDIR --- C ----------------- DO 56 J=1,MR IF(IREGIO(J).EQ.0)GOTO 56 DO 55 I=1,NMT IF(REFMAT(I).EQ.IREGIO(J)) THEN GOTO 56 ENDIF 55 CONTINUE C --- AJOUT D'UNE NOUVELLE REGION NMT = NMT+1 IF(MAXRMA.GE.NMT)REFMAT(NMT)=IREGIO(J) 56 CONTINUE 66 CONTINUE C IF(ACTION.LE.0) THEN NBNMAX=MM NBRMAX=MMR GOTO 9995 ENDIF IF(MAXRMA.GT.0.AND.MAXRMA.LT.NMT) GOTO 907 IF(MAXTMA.GT.0.AND.MAXTMA.LT.(2*NBE)) GOTO 907 IF(MAXITR.GT.0.AND.MAXITR.LT.NBNMAX*NBE) GOTO 907 C REWIND IT READ(IT,*,ERR=912,END=912) NEL C ====================================== C --- 4. LECTURE DES MAILLES --- C ici NBNMAX,NBRMAX doivent etre donnes par l'appelant C MAXITR,MAXTMA doivent etre non nuls ! C ====================================== NBE=0 DO 500 IEL=1,NEL CALL LITGEO(IT,IDEE,INODES,MAXNOD,M,IREGIO,MAXREG,MR,ITYPE,IERR) IF(IERR.NE.0)GOTO 913 C GOTO(100,200,300) ITYPE-98 GOTO 913 C --- des sommets isoles : 99 --- C ------------------------- 100 CONTINUE DO 169 INOD=1,M C --- recopie les noeuds dans la structure de donnees NBE = NBE+1 IF((MAXITR.GE.NBE*NBNMAX).AND.(NBNMAX.GT.0))THEN ITRNOE((NBE-1)*NBNMAX+1)= INODES(INOD) ITRNOE((NBE-1)*NBNMAX+2)= 0 ENDIF C --- recopie les regions dans la structure de donnees IF((MAXTMA.GE.NBE*NBRMAX).AND.(NBRMAX.GT.0))THEN DO 167 J=1,MR TRIMAT((NBE-1)*NBRMAX+J)= IREGIO(J) 167 CONTINUE DO 168 J=MR+1,NBRMAX TRIMAT((NBE-1)*NBRMAX+J)= 0 168 CONTINUE ENDIF 169 CONTINUE GOTO 500 C --- une arete ou une polyligne : 100 --- C -------------------------------- 200 CONTINUE DO 269 ISEG=1,M-1 C --- recopie les noeuds dans la structure de donnees NBE = NBE+1 IF((MAXITR.GE.NBE*NBNMAX).AND.(NBNMAX.GT.0))THEN ITRNOE((NBE-1)*NBNMAX+1)= INODES(ISEG) ITRNOE((NBE-1)*NBNMAX+2)= INODES(ISEG+1) ENDIF C --- recopie les regions dans la structure de donnees IF((MAXTMA.GE.NBE*NBRMAX).AND.(NBRMAX.GT.0))THEN DO 267 J=1,MR TRIMAT((NBE-1)*NBRMAX+J)= IREGIO(J) 267 CONTINUE DO 268 J=MR+1,NBRMAX TRIMAT((NBE-1)*NBRMAX+J)= 0 268 CONTINUE ENDIF 269 CONTINUE GOTO 500 C --- un arc de cercle : 101 --- 300 CONTINUE IERR = -3 CALL ESERRE(1,IERR,'LITFRT',' NON IMPLEMENTE') GOTO 9999 500 CONTINUE GOTO 9995 C --------------------------------------------- C --- NOUVEAU TRAITEMENT DES ERREURS (UTILISATEUR)--- C --------------------------------------------- 906 IERR =-1 CALL ESMESS(IERR,12,1,'DANS BLOC XYZ : DIM INCORRECTE',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 907 IERR =-2 CALL ESMESS(IERR,13,1,'INCONNUE : PB ALLOCATION MEMOIRE?',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 908 IERR =-1 CALL ESMESS(IERR,14,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 909 IERR =-1 CALL ESMESS(IERR,15,1,'BLOC XYZ: DEBUT OU FIN ABSENT',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 910 IERR = -1 CALL ESMESS(IERR,16,1,'BLOC XYZ: NB POINTS OU DIM INVALID',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 911 IERR = -1 CALL ESMESS(IERR,17,1,'ERREUR A LA LECTURE DU POINT : ',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 9995 912 IERR = -1 CALL ESMESS(IERR,18,1,'NOMBRE DE FRONTIERE OU DIM INVALID',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 913 IERR = -1 CALL ESMESS(IERR,19,1,'A LA FRONTIERE :',MESSAG) CALL ESEINT(1,MESSAG,IEL,1) GOTO 9995 914 IERR = -1 CALL ESMESS(IERR,20,1,'POINT ERRONE SUR LA FRONTIERE :',MESSAG) CALL ESEINT(1,MESSAG,IEL,1) GOTO 9995 916 IERR = -1 CALL ESMESS(IERR,21,1,'DIM < DIM ELEMENT !',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 917 IERR = 0 C --- ce n'est plus une erreur ! --- C CALL ESERRO(1,IERR,'BLOC ILM OU ARE', C > 'LABEL DE DEBUT OU DE FIN ABSENT') GOTO 9995 918 IERR = 0 C --- ce n'est plus une erreur ! --- C CALL ESERRO(1,IERR,'BLOC ILM OU ARE','ATTENTION PAS D ARETE') GOTO 9995 920 IERR = -2 CALL ESMESS(IERR,22,1,'BLOC XYZ: DIMENSION TROP ELEVEE<',MESSAG) CALL ESEINT(1,MESSAG,MAXCOO,1) GOTO 9995 C --- FIN --- 9995 CALL GESFIC('F',' ',0,0,IN,I) CALL GESFIC('F',' ',0,0,IT,I) 9999 END C SUBROUTINE ESLIFR(NOMD,IDE,IDIMC,NBNMAX,NBCMAX, > ITRNOE,NBEMAX, > COORD,NBPMAX,NBE,NBN, > IMAT,NMAT, > ITVL,IMAX, > IERR) C ********************************************************************** C OBJET ESLIFR : LIT UN MAILLAGE FRONTIERE (DU MAILLAGE A CALCULER) C ---> UTILISE POUR LE 3D C C 3 TYPES DE FRONTIERES : C FRONTIERES REELLES (VIDE/PLEIN) C IMAT() = (0,+I) OU (+I,0) C FRONTIERES INTER-MATERIAUX (MATI/MATJ) C IMAT() = (+I,+J) C FRONTIERES GEOMETRIQUES (MATI/MATI) C IMAT() = (+I,+I) C UN MATERIAU INCONNU = -1 C C C IMAT : MATERIAU A DROITE ET A GAUCHE DES ARETES FRONTIERES C (MATG(I),MATD(I)) I EST LE NUMERO DE L'ELEMENT C DANS ITRNOE C C EN ENTREE : C NOMD : NOM DU FICHIER CONTENANT LES DONNEES C IDIMC : C NBNMAX : C NBCMAX : C C ---- TABLEAUX DE TRAVAIL -------------------- C ITVL : TABLEAU D'ENTIERS = NBRE DE MATERIAUX C NITRMAX : TAILLE DE ITVL C C EN SORTIE : C IDE,NBNMAX,NBCMAX,ITRNOE,NBN,NBE : LE MAILLAGE C IDIMC,COORD : COORDONNES DES POINTS C IMAT : LE TABLEAU DES REGIONS DROITE ET GAUCHE C IERR : CODE D'ERREUR -1 SI DONNEES INCORRECTES C -2 SI TABLEAUX INSUFFISANTS C ********************************************************************** CHARACTER*(*) NOMD INTEGER IDE,IDIMC INTEGER NBNMAX,NBCMAX INTEGER ITRNOE(*),IMAT(*),ITVL(*),IMAX INTEGER NBPMAX,NBEMAX INTEGER NBE,NBN,NMAT REAL COORD(*) INTEGER IERR C ----------------------------------------------------------------- C MODIF 29.11.99 PROVISOIRE (POUR PASSER ZACK) INTEGER NRGMAX PARAMETER (NRGMAX=1000) INTEGER REFMAT(NRGMAX) INTEGER I,J,IDMAT,IFMAT,MATD,MATG,NMT,ITRIRG INTEGER NBRMAX C ----------------------------------------------------------------- IERR = 0 ITRIRG = 1 C =================================== C --- 1. LECTURE D'UNE FRONTIERE --- C =================================== C DANS L'ANCIENNE VERSION NBRMAX=2 ! NBRMAX = 2 CALL LITFRT(1,NOMD,NBPMAX*IDIMC,NBEMAX*NBNMAX,NRGMAX,NBEMAX, > IDIMC,NBN,COORD,IDE,NBNMAX,NBE, C > ITRNOE,NMT,REFMAT,IMAT,IERR) > ITRNOE,NMT,REFMAT,NBRMAX,IMAT,IERR) C IF( IERR.EQ.0 )GOTO 9999 C --- ON ESSAYE L'ANCIENNE VERSION --- IERR = 0 C ===================================================== C --- 1. LECTURE D'UN MAILLAGE LINEIQUE (ANCIENNE VERSION) --- C ===================================================== CALL LITVIP(1,NOMD,NBPMAX*IDIMC,NBEMAX*NBNMAX,NRGMAX,NBEMAX, > IDIMC,NBN,COORD,IDE,NBNMAX,NBE, > ITRNOE,NMT,REFMAT,ITVL(ITRIRG),IERR) IF( IERR.NE.0 )GOTO 9999 C --- REORGANISATION DES MATERIAUX ------------------- C LES ARETES DE LA FRONTIERE REELLE (MAT > 0) C LES ARETES DES FRONTIERES INTER-MATERIAUX (MAT < 0) C LES ARETES IMPOSEES POUR LES RACCORDS (MAT = 0) C ---------------------------------------------------- IDMAT = 1 DO 20 I=1,NMT IFMAT = ITVL(ITRIRG+I-1) IF( REFMAT(I) .LT.0 )THEN MATG = - REFMAT(I) MATD = - 1 ELSE IF( REFMAT(I) .EQ.0 )THEN MATG = -1 MATD = -1 ELSE MATG = REFMAT(I) MATD = REFMAT(I) ENDIF ENDIF DO 10 J=IDMAT,IFMAT IMAT((J-1)*2+1) = MATG IMAT((J-1)*2+2) = MATD 10 CONTINUE IDMAT = IFMAT+1 20 CONTINUE C =================================================== C --- ON NE PREND QUE LES VALEURS POSITIVES DISTINCTES --- C =================================================== DO 30 I=1,NMT REFMAT(I) = ABS(REFMAT(I)) 30 CONTINUE IF( NMT.GT.1 )THEN CALL ESTBVT(REFMAT,NMT,ITVL,REFMAT,NMAT, > NMT,IERR) ELSE NMAT = NMT ENDIF 9999 END C C SUBROUTINE ESTBVT(ITABRG,NBE,ITVL,IREFRG,NBREF, > NREFMX,IERR) C ********************************************************************** C OBJET ESTBVT: RENVOI LES VALEURS DISTINCTES D'UN TABLEAU, C TRIEES DANS L'ORDRE CROISSANT (COPIE DE TBVTAB) C EN ENTREE : C ITABRG : UN ENSEMBLE DES REFERENCES C (PAR EXEMPLE ITABRG(I) = MATERIAU DE L'ELEMENT I) C NBE : NOMBRE DE REFERENCES C ITVL: TABLEAU DE TRAVAIL DE TAILLE = NBE C C IREFRG : TABLEAU RESULTAT (ON PEUT UTILISER ITABRG) C NREFMX: TAILLE DU TABLEAU RESULTAT C C EN SORTIE : C IREFRG : LES REFERENCES DISTINCTES DE IREFRG TRIEES DANS C L'ORDRE CROISSANT C NBREF : NOMBRE DE REFERENCES DISTINCTES (ON PEUT UTILISER NBE) C IERR : 0 SI OK C -2 SI IREFRG EST TROP PETIT C ********************************************************************** INTEGER ITABRG(*),NBE,IREFRG(*),NBREF,ITVL(*) INTEGER NREFMX,IERR C INTEGER I,IREF,NBREF2 C IREF = 1 DO 10 I=1,NBE ITVL(IREF-1+I) = ITABRG(I) 10 CONTINUE CALL ESKNUT(NBE,ITVL(IREF)) NBREF2 = 1 IF(NREFMX.GT.0)THEN IREFRG(NBREF2) = ITVL(IREF) ELSE IERR = -2 ENDIF DO 20 I=2,NBE IF( ITVL(I-1+IREF).NE.ITVL(NBREF2-1+IREF) ) > NBREF2 = NBREF2+1 IF( NREFMX.GE.NBREF2 )THEN IREFRG(NBREF2) = ITVL(I-1+IREF) ELSE IERR = -2 ENDIF 20 CONTINUE NBREF = NBREF2 999 END C SUBROUTINE ESKNUT(N,NARG) C *************************************************************** C OBJET ESKNUT : TRI UN TABLEAU D'ENTIERS DANS L'ORDRE CROISSANT C TRI PAR INCREMENT DECROISSANT (SHELL SORTING - KNUTH 1973) C (COPIE DE KNUTA) C ON TRIE LES N TERMES NARG(I) POUR I=1,N C C TRI PAR INCREMENT DECROISSANT (SHELL SORTING) C COMPLEXITE EN N PUISSANCE 3/2 ET MEME STATISTIQUEMENT EN N**1.2 C C POUR EN SAVOIR PLUS : KNUTH, "THE ART OF COMPUTER PROGRAMMING", C VOL 3 : SORTING AND SEARCHING, C ADDISON-WESLEY, 1973. C C KNUTA : A COMME ACTIF, C.A.D. QUE LES ARGUMENTS NARG(I) POUR C I=1 A N SONT PHYSIQUEMENT "PERMUTES" (TABLEAU NARG MODIFIE). C VOIR AUSSI KNUTP. C C C REMARQUE : NARG PEUT ETRE DE TOUT TYPE ET TOUTE LOI D'ORDRE C PEUT ETRE INTRODUITE. IL SUFFIT D'INTERVENIR C AUX ENDROITS INDIQUES AINSI : '***** ICI : ...'. C C *************************************************************** INTEGER N,NARG(*) INTEGER NARGJ INTEGER I,J,K,INCR C C ON N'A RIEN A TRIER C IF(N.LE.1) GOTO 9999 C C POUR J=INCR+1,N, LA SOUS-SUITE NARG(J+H*INCR), H=...,-3,-2,-1,0 C SERA ORDONNEE (TRI HABITUEL PAR INSERTION SEQUENTIELLE). C C DES QUE INCR=1 ON A ATTEINT L'OBJECTIF FINAL. C C INCR SUBIT UNE DECROISSANCE PROGRESSIVE DE SORTE QU'AU C DEBUT IL EST GRAND (LA SOUS-SUITE A TRIER A UN CARDINAL FAIBLE) C ENSUITE QUAND INCR DIMINUE LA PROFONDEUR DES PERMUTATIONS C NECESSAIRES RESTE LIMITEE GRACE AU TRI DE LA SOUS-SUITE C CORRESPONDANT A LA VALEUR PRECEDENTE DE L'INCREMENT (LE PAS). C INCR=N C C DECROISSANCE DE L'INCREMENT PAR DIVISION PAR 2 C 10 INCR=INCR/2 C C POUR TOUT J VARIANT DE INCR+1 A N, C LA SOUS-SUITE NARG(J+H*INCR) AVEC H=...,-3,-2,-1,0 C SERA ORDONNEE. C DO 40 J=INCR+1,N C C ON PROCEDE PAR RECURENCE : LE FAIT QUE LES ELEMENTS C NARG(J+H*INCR) DEPUIS LE DEBUT JUSQU'A J+H*INCR=K-INCR C SOIENT DEJA ORDONNES EST UTILISE POUR ALLER JUSTE PLACER C CONVENALEMENT L'ELEMENT NARG(K) : INSERTION SEQUENTIELLE. C C C ***** ICI : SAUVEGARDE DE NARG(J) C NARGJ=NARG(J) K=J DO 20 I=J-INCR,1,-INCR C C ***** ICI : LOI D'ORDRE C COMPARER NARG(I) ET NARGJ=NARG(J) C SI NARG(I) EST AVANT OU EGAL A NARGJ ALLER EN 30 C IF(NARG(I).LE.NARGJ) GOTO 30 C C ***** ICI : AFFECTER LE CONTENU DE NARG(I) A NARG(K) C NARG(K)=NARG(I) K=I 20 CONTINUE C C ***** ICI : AFFECTER LE CONTENU DE NARGJ A NARG(K) C 30 NARG(K)=NARGJ C C FIN DU TRI DE LA SOUS-SUITE ASSOCIEE A J C 40 CONTINUE C C PEUT-ON ENCORE DIMINUER L'INCREMENT (LE PAS) ? C IF(INCR.GT.1) GOTO 10 C C INCR=1, LE TRI FINAL EST ACHEVE. MERCI DE VOTRE VISITE. C 9999 END C SUBROUTINE CODARE(IDE,NBNMAX,ITRNOE,NCODE,NBNE,IERR) C ***************************************************************** C OBJET CODARE : CODE EN FONCTION DU NOMBRE DE NEOUD ET DIMENSION C PB : il y a un probleme pour IDE=1 et NBNE=3 : comment distinguer C un element quadratique d'une polyligne. C ***************************************************************** INTEGER IDE,NBNMAX,ITRNOE(*) INTEGER NCODE,NBNE,IERR C NBNE = NBNMAX NCODE = -1 IERR = -1 IF( IDE.GT.1 )GOTO 9999 10 IF(ITRNOE(NBNE).EQ.0)THEN NBNE = NBNE - 1 IF(NBNE.EQ.0)GOTO 9999 GOTO 10 ENDIF IF( NBNE.EQ.1 )NCODE=99 IF( NBNE.EQ.2 )NCODE=100 9999 IF( NCODE.NE.-1)IERR=0 END C SUBROUTINE ECRFRT(ACTION,NOM, > IDIMC,NBN,COORD,IDE,NBNMAX,NBE,ITRNOE, > ITRIRG,NBRMAX,IERR) C ***************************************************************** C OBJET ECRFRT : ecriture des fichiers maillage au format ARE C C EN ENTREE : C ACTION : C ACTION=1 : ecriture d'un nouveau fichier C ACTION=2 : " " ou ecrasement d'un fichier existant C ACTION=3 : concatenation en fin d'un fichier existant C C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBN : NOMBRE TOTAL DES POINTS (NOEUDS) C IDE : DIMENSION MAXIMALE DE LA TOPOLOGIE DES ELEMENTS C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C NBE : NOMBRE D'ELEMENTS C NMT : NOMBRE DE MATERIAUX C SI NMT = 0 ALORS LE MATERIAU DE TOUS LES ELEMENTS C EST FIXE A 1 C REFMAT : LE TABLEAU REFMAT CONTIENDRA LES ENTIERS REFERENCES DES C COORD : LE TABLEAU REEL COORD. C ITRNOE : TABLEAU DES ELEMENTS C C EN SORTIE : C IER=0 : PAS D'ERREUR C IER=-1 : PROBLEME D'OUVERTURE DU FICHIER C IER=-2 : L'UN DES TABLEAUX EST TROP PETIT C C ***************************************************************** CHARACTER*(*) NOM INTEGER ACTION INTEGER IDIMC,NBN,IDE,NBNMAX,NBE,IERR REAL COORD(*) INTEGER ITRNOE(*) INTEGER ITRIRG(*),NBRMAX C INTEGER IUNIT,I,J,K INTEGER NBNE,NCODE,NBMAT CHARACTER*256 MESSAG C GOTO (1,2,3) ACTION 1 CONTINUE C --- Creation d'un nouveau fichier CALL GESFIC('O',NOM,0,0,IUNIT,IERR) IF(IERR.NE.0)GOTO 901 GOTO 9 2 CONTINUE C --- ecriture d'un nouveau fichier ou ecrasement d'un fichier existant CALL GESFIC('O',NOM,3,0,IUNIT,IERR) IF(IERR.NE.0)GOTO 902 GOTO 9 3 CONTINUE C --- concatenation en fin d'un fichier existant IERR = -3 GOTO 904 9 CONTINUE C C I. ECRITURE DES NOEUDS C ---------------------- WRITE(IUNIT,'(A)')'DEBXYZ' WRITE(IUNIT,*) NBN, IDIMC DO 10 I=1,NBN WRITE(IUNIT,*) (COORD((I-1)*IDIMC+J),J=1,IDIMC) 10 CONTINUE WRITE( IUNIT,'(A)')'FINXYZ' C C I. ECRITURE DES ELEMENTS C ------------------------ IF( NBE .EQ. 0 )GOTO 100 WRITE(IUNIT,'(A)')'DEBARE' WRITE(IUNIT,*) NBE DO 70 J=1,NBE CALL CODARE(IDE,NBNMAX,ITRNOE((J-1)*NBNMAX+1),NCODE,NBNE,IERR) NBMAT=0 DO 80 K=1,NBRMAX IF(ITRIRG((J-1)*NBRMAX+K).GT.0)NBMAT=NBMAT+1 80 CONTINUE IF(IERR.NE.0)GOTO 903 WRITE(UNIT=IUNIT,FMT='(11I10)')NBNE, > (ITRNOE((J-1)*NBNMAX+K),K=1,NBNE), > NCODE,NBMAT,(ITRIRG((J-1)*NBRMAX+K),K=1,NBMAT) 70 CONTINUE WRITE( IUNIT,'(A)')'FINARE' C 100 CALL GESFIC('F',NOM,0,0,IUNIT,IERR) GOTO 9999 c ----------- messages d'erreur -------------- 901 CONTINUE CALL ESMESS(IERR,23,1,'ATTENTION LE FICHIER EXISTE DEJA',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 902 CONTINUE CALL ESMESS(IERR,24,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 903 CONTINUE CALL ESMESS(IERR,25,1,'A L ECRITURE D UN ELEMENT',MESSAG) CALL ESEINT(1,MESSAG,J,1) CALL GESFIC('F',NOM,0,0,IUNIT,IERR) GOTO 9999 904 CONTINUE CALL ESMESS(IERR,1,1,'PAS ENCORE IMPLEMENT',MESSAG) CALL ESECHA(1,MESSAG,' ') c 9999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_UTIL.F C OBJET : UTILITAIRES POUR LES OPERATIONS : ENTREE/SORTIE C FONCT. : C GESFIC : OUVERTURE ET FERMETURE DES FICHIERS C OBJET FITEST : TESTE L'EXISTANCE DU FICHIER C OBJET GESCOM : ENLEVE LES COMMENTAIRES ENTRE 2 LABELS C VDCHAR : VIDER UN TABLEAU CHARACTER DANS UN AUTRE C VDENTI : VIDER UN TABLEAU INTEGER DANS UN AUTRE C LENCHR : LONGUEUR D'UNE CHAINE DE CARACTERES C MAJUSC : TRANSFORMER EN MAJUSCULES UNE CHAINE C AUTEUR : S-M. TIJANI C DATE : 03.95 C LIMITATIONS : C LIMITATION GESCOM : LIGNE 256 CARACTERES C LIMITATION GESFIC : OUVERTURE 25 FICHIERS C LIMITATION GESFIC : NOM DE FICHIER 256 CARACTERES C LIMITATION MAJUSC : MOTS DE 26 CARACTERES C MODIFICATIONS : C AUTEUR, DATE, OBJET : C O.STAB, 14.03.2001, MODIFICATION LIMITATION LIGNE 80->256 ET DOC C O.STAB, 20.09.2004, MODIFICATION GESCOM quand IT=0 C O.STAB, 26.05.2005, MODIFICATION GESCOM gestion ' ' avant les labels C C ***************************************************************** C SUBROUTINE GESCOM(IN,DEBUT,LD,FIN,LF,LET,IT,NBLC,IERR) C ***************************************************************** C OBJET GESCOM : ENLEVE LES COMMENTAIRES ENTRE 2 LABELS C C EN ENTREE : C IN : FICHIER AVEC COMMENTAIRES C DEBUT : LABEL DE DEBUT DU TRAITEMENT C FIN : LABEL DE FIN DU TRAITEMENT C LET : DE DEBUT D'UNE LIGNE DE COMMENTAIRE C EN SORTIE : C IT : FICHIER SANS COMMENTAIRES C SI IT=0 IL N'Y A PAS DE FICHIER C NBLC : NOMBRE DE LIGNES DE COMMENTAIRES SUPPRIMEES C NBEN : NOMBRE D'ENREGICTREMENTS DU BLOC (A FAIRE) C C 0 : PAS D'ERREUR C -1 : UNE ERREUR, DEBUT OU FIN N'ONT PAS ETE TROUVES C C LIMITATION GESCOM : LIGNE 256 CARACTERES C C ***************************************************************** INTEGER IN,IT,LD,LF CHARACTER*(*) DEBUT,FIN CHARACTER LET INTEGER NBLC,IERR C INTEGER NBEN INTEGER MAXFICH PARAMETER(MAXFICH=25) C CHARACTER*80 LNG CHARACTER*256 LNG INTEGER LENCHR,I,ID C IERR = 0 NBLC = 0 NBEN = 0 IF((IT.LT.0).OR.(IT.GT.MAXFICH))GOTO 80 C 10 READ(IN,'(A)',ERR=80,END=80) LNG C CALL MAJUSC(LD,LNG) ID=1 11 IF(LNG(ID:ID).NE.' ') GOTO 12 ID=ID+1 GOTO 11 12 CONTINUE CALL MAJUSC(LD+ID-1,LNG) IF(LNG(ID:LD+ID-1).NE.DEBUT) GOTO 10 C IF(LNG(:LD).NE.DEBUT) GOTO 10 C 20 READ(IN,'(A)',ERR=80,END=80) LNG IF(LNG(:1).EQ.LET)THEN NBLC = NBLC+1 GOTO 20 ENDIF C CALL MAJUSC(LF,LNG) ID=1 21 IF(LNG(ID:ID).NE.' ') GOTO 22 ID=ID+1 GOTO 21 C IF(LNG(:LF).NE.FIN) THEN 22 CONTINUE CALL MAJUSC(LF+ID-1,LNG) IF(LNG(ID:LF+ID-1).NE.FIN) THEN I=LENCHR(LNG) IF(IT.GT.0)WRITE(IT,'(A)') LNG(:I) NBEN = NBEN + 1 GOTO 20 ENDIF GOTO 999 80 IERR = -1 C 999 END C C INTEGER FUNCTION FITEST(NOM,ISTAT,IFORM) C ***************************************************************** C OBJET FITEST : TESTE L'EXISTANCE DU FICHIER C C EN ENTREE : C NOM : NOM DU FICHIER A OUVRIR C ISTAT=0 (NEW), 1 (OLD) C IFORM=0 ('FORMATTED') OU 1 ('UNFORMATTED') C RENVOI : C 0 : PAS D'ERREUR C SI ISTAT=0 ET LE FICHIER N'EXISTE PAS C SI ISTAT=1 ET LE FICHIER EXISTE C -1 : UNE ERREUR C SI ISTAT=0 ET LE FICHIER EXISTE DEJA C SI ISTAT=1 ET LE FICHIER N'EXISTE PAS C C ***************************************************************** CHARACTER*(*) NOM INTEGER ISTAT,IFORM C INTEGER IUNIT,IER C C --- LE TEST : LE CAS CONTRAIRE DOIT PROVOQUER UNE ERREUR --- C FITEST = 0 IF( ISTAT.EQ. 0 )THEN C C --- CREATION : ON TESTE SI LE FICHIER N'EXISTE PAS DEJA C L'OUVERTURE DU FICHIER EXISTANT DOIT PROVOQUER UNE ERREUR C CALL GESFIC('O',NOM,1,IFORM,IUNIT,IER) IF( IER.NE. -2 )FITEST = -1 CALL GESFIC('F',' ',0,0,IUNIT,IER) ELSE C C --- EXISTANT :ON TESTE SI LE FICHIER EXISTE C CALL GESFIC('O',NOM,1,IFORM,IUNIT,IER) IF( IER.NE. 0 )THEN FITEST = -1 ELSE CALL GESFIC('F',' ',0,0,IUNIT,IER) ENDIF ENDIF C CALL GESFIC('O',NOM,0,IFORM,IUNIT,IER) C IF( IER.NE. -1 )GOTO 9999 C ENDIF C FITEST = 0 C 9999 END C C SUBROUTINE GESFIC(FLG,NOM,ISTAT,IFORM,IUNIT,IER) C ***************************************************************** C OBJET GESFIC : GESTION OUVERTURE/FERMETURE DE FICHIERS : C C 1) OUVERTURE C EN ENTREE : C FLAG FLG='O' (CALL GESFIC('O',...) C NOM : NOM DU FICHIER A OUVRIR C ISTAT=0 (NEW), 1 (OLD), 2 (SCRATCH) OU 3 (UNKNOWN) C IFORM=0 ('FORMATTED') OU 1 ('UNFORMATTED') C EN SORTIE : C IUNIT : UNITE LOGIQUE ASSOCIEE AU FICHIER C IER=0 : PAS D'ERREUR C IER=1 : FICHIER DEJA OUVERT PAR GESFIC (FICHIER ASCII) C IER=2 : FICHIER DEJA OUVERT PAR GESFIC (FICHIER BINAIRE) C IER=-1 : ISTAT=0 ET FICHIER EXISTANT C IER=-2 : ISTAT=1 ET FICHIER INEXISTANT C IER=-3 : TROP DE FICHIERS OUVERTS (IUNIT=MAXFICH) C C 2) FERMETURE C EN ENTREE : C FLAG FLG='F' (CALL GESFIC('F',...) C IUNIT : UNITE LOGIQUE ASSOCIEE AU FICHIER (1 A 25) C EN SORTIE : C IER=0 : PAS D'ERREUR C IER=-4 : FICHIER NON OUVERT PAR GESFIC C IER=-5 : PROBLEME AVEC CLOSE C C 3) AUTRE C FLAG FLG INCONNU (NI O NI F) : IER=-6 C C MEMOIRE LOCALE : C NFICH : NOMBRE DE FICHIERS OUVERTS C NOML(I) : NOM DU IEME FICHIER OUVERT PAR GESFIC (I=1,NFICH) C IUNITL(I) : UNITE LOGIQUE ASSOCIEE AU IEME FICHIER C IFORML(I) : 0 (ASCII) OU 1 (BINAIRE) C C LIMITATION GESFIC : OUVERTURE 25 FICHIERS C LIMITATION GESFIC : NOM DE FICHIER 256 CARACTERES C C ***************************************************************** CHARACTER*(*) NOM,FLG INTEGER ISTAT,IFORM,IUNIT,IER C INTEGER MAXFICH PARAMETER(MAXFICH=25) CHARACTER NOML(MAXFICH)*256 INTEGER IUNITL(MAXFICH),IFORML(MAXFICH) CHARACTER F*12,S*7 INTEGER NFICH,I C --- BUG_31 : O.STAB 17.10.97. LES VALEURS POUVAIENT ETRE ECRASEES --- SAVE IUNITL,IFORML,NOML,NFICH C DATA NFICH /0/ C IF(FLG.NE.'O'.AND.FLG.NE.'O') GOTO 30 C LE MAX. DE FICHIERS OUVRABLES EST-IL DEPASSE ? IF(NFICH.GE.MAXFICH) THEN IER=-3 IUNIT=MAXFICH GOTO 999 ENDIF C LE FICHIER N'EST-IL PAS DEJA OUVERT ? IUNIT=1 IF(NFICH.LE.0) GOTO 20 DO 10 I=1,NFICH IF(NOML(I).EQ.NOM) THEN IUNIT=IUNITL(I) IER=1+IFORML(I) GOTO 999 ENDIF 10 CONTINUE C on "ouvre" un nouveau fichier IUNIT=IUNITL(NFICH)+1 20 IF(IFORM.EQ.0) THEN F='FORMATTED' ELSE F='UNFORMATTED' ENDIF IF(ISTAT.EQ.0) S='NEW' IF(ISTAT.EQ.1) S='OLD' IF(ISTAT.EQ.3) S='UNKNOWN' C UNITES RESERVEES 5 (CLAVIER), 6 (ECRAN), 7 (AUTRE) IF(IUNIT.EQ.5) IUNIT=IUNIT+3 IER=-1-ISTAT IF(ISTAT.EQ.2) THEN OPEN(UNIT=IUNIT,STATUS='SCRATCH',FORM=F,ERR=999) NFICH=NFICH+1 WRITE(NOML(NFICH),'(A,I4.4)')'TEMPORAIRE.SCRATCH.',IUNIT ELSE OPEN(UNIT=IUNIT,FILE=NOM,STATUS=S,FORM=F,ERR=999) NFICH=NFICH+1 NOML(NFICH)=NOM ENDIF IUNITL(NFICH)=IUNIT IFORML(NFICH)=IFORM IER=0 GOTO 999 30 IF(FLG.NE.'F'.AND.FLG.NE.'F') GOTO 90 IF(NFICH.LE.0) GOTO 50 DO 40 I=1,NFICH IF(IUNITL(I).EQ.IUNIT) THEN CLOSE(UNIT=IUNIT,ERR=60) CALL VDCHAR(1,NFICH-I,NOML(I+1),NOML(I)) CALL VDENTI(1,NFICH-I,IUNITL(I+1),IUNITL(I)) CALL VDENTI(1,NFICH-I,IFORML(I+1),IFORML(I)) NFICH=NFICH-1 IER=0 GOTO 999 ENDIF 40 CONTINUE C LE FICHIER N'EXISTE PAS 50 IER=-4 GOTO 999 60 IER=-5 GOTO 999 90 IER=-6 999 END C SUBROUTINE VDCHAR(K,N,L,M) C ***************************************************************** C OBJET VDCHAR : COPIE UN TABLEAU DE CHARAC.(L) DANS UN AUTRE (M) C VIDER L(I) DANS M(I) POUR I=1,N. C.A.D. FAIRE M(I)=L(I) C K = 1 : BOUCLE DIRECTE CALL VDCHAR( 1,N,JJJ(12),JJJ(5)) C K = -1 : BOUCLE INVERSE CALL VDCHAR(-1,N,JJJ(5),JJJ(12)) C C ***************************************************************** INTEGER K,N CHARACTER*(*) L(*) CHARACTER*(*) M(*) C INTEGER I C IF(N.LE.0) GOTO 999 IF(K.EQ.-1) GOTO 20 DO 10 I=1,N M(I)=L(I) 10 CONTINUE GOTO 999 20 DO 30 I=N,1,-1 M(I)=L(I) 30 CONTINUE 999 END C SUBROUTINE VDENTI(K,N,L,M) C ***************************************************************** C OBJET VDENTI : COPIE UN TABLEAU D'ENTIERS (L) DANS UN AUTRE (M) C VIDER L(I) DANS M(I) POUR I=1,N. C.A.D. FAIRE M(I)=L(I) C K = 1 : BOUCLE DIRECTE CALL VDENTI( 1,N,JJJ(12),JJJ(5)) C K = -1 : BOUCLE INVERSE CALL VDENTI(-1,N,JJJ(5),JJJ(12)) C C ***************************************************************** INTEGER K,N INTEGER L(*) INTEGER M(*) C INTEGER I C IF(N.LE.0) GOTO 999 IF(K.EQ.-1) GOTO 20 DO 10 I=1,N M(I)=L(I) 10 CONTINUE GOTO 999 20 DO 30 I=N,1,-1 M(I)=L(I) 30 CONTINUE 999 END C C SUBROUTINE MAJUSC(N,C) C ***************************************************************** C OBJET MAJUSC : TRANSFORME DES CARACTERES MINUSCULE -> MAJUSCULE C TRANSFORME EN MAJUSCULES LES N CARACTERES (C(I:I),I=1,N) C C LIMITATION MAJUSC : MOTS DE 26 CARACTERES C C ***************************************************************** INTEGER N CHARACTER C*(*) C CHARACTER*26 MINUS,MAJUS INTEGER I,K,M C DATA MINUS /'abcdefghijklmnopkrstuvwxyz'/ DATA MAJUS /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ C M=MIN(N,LEN(C)) IF(M.LE.0) GOTO 999 DO 10 I=1,M K=INDEX(MINUS,C(I:I)) IF(K.GE.1) C(I:I)=MAJUS(K:K) 10 CONTINUE 999 END C INTEGER FUNCTION LENCHR(C) C ***************************************************************** C OBJET LENCHR : RENVOI LA VRAI TAILLE DE LA CHAINE C C LENCHR(C) = VRAIE TAILLE DE LA CHAINE C C AUTREMENT DIT : N=LENCHR(C) EST TEL QUE C(N:N) N'EST PAS BLANC C MAIS C(N+1:) EST UNE SOUS-CHAINE BLANCHE. C REMARQUE : SI LA CHAINE C N'EXITE PAS, LENCHR=0 C SI LA CHAINE C EST TOUTE BLANCHE, LENCHR=1 C C ***************************************************************** CHARACTER*(*) C C INTEGER N,I C N=LEN(C) I=0 IF(N.LE.0) GOTO 20 DO 10 I=N,1,-1 IF(C(I:I).NE.' ') GOTO 20 10 CONTINUE I=1 20 LENCHR=I 999 END C C *************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_DENSITE.F C OBJET : LECTURE DES INFORMATIONS DE DENSITE (FONCTION ANALYTIQUES) C C FONCT. : C OBJET DEFDEN : DEFINIE LA DENSITE PAR DEFAUT C OBJET INIDEN : INITIALISE LES DENSITES (A PARTIR D'UN FICHIER) C C FONCT. LOCALES : C OBJET LITDEN : LIT LA DENSITE DANS UN FICHIER C OBJET STRDEN : CONSTRUIT LES FONCTIONS DE DENSITE C C AUTEUR : O. STAB C DATE : 03.95 / 06.95 / 04.97 / 05.98 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 10.04.97, DENSITE VALEURS NODALES C AJOUT DU PARAMETRE IACTIO DANS INIDEN C AUTEUR, DATE, OBJET : O.STAB, 22.10.97, STRDEN (VERIF ENTREES) C AUTEUR, DATE, OBJET : O.STAB, 28.05.98, RESTRUCTURATION IMPORTANTE C AUTEUR, DATE, OBJET : O.STAB, 8/4/2002,remp. de DSERRE par ESERRO C AUTEUR, DATE, OBJET : O.STAB, 17/9/2004, messages pour LITDEN en plus ! C C *************************************************************** C C SUBROUTINE LITDEN(IACTIO,NOM,COORD,IDIMC,NBPT,NBPTMX, > ISUI,FSUI,NBSUI,NBSUMX,IDEN,NBDEN,NBDNMX, > MODGEN,IERR) C *************************************************************** C OBJET LITDEN : LIT LA DENSITE DANS UN FICHIER (LOCAL) C C EN ENTREE : C IACTIO : ENTIER INDIQUANT AU S/PROGRAMME LES ENTITES A LIRE C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C NBPTMX : NOMBRE MAXI. DE POINTS (COORD) C NBSUMX : NOMBRE MAXI. DE SUITES (ISUI,FSUI) C NBDNMX : NOMBRE MAXI. DE DENSITES (IDENS) C C EN SORTIE : C IER=O : PAS D'ERREUR C IER=-1 : PROBLEME D'OUVERTURE DU FICHIER / OU DE FORMAT C IER=-2 : L'UN DES TABLEAUX EST TROP PETIT C SI IACTIO = 0 C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBSUI : NOMBRE DE SUITES (NUMERO MAXIMUM) C NBPT : NOMBRE TOTAL DES POINTS (NUMERO MAXIMUM) C NBDEN : NOMBRE DE DENSITES (NUMERO MAXIMUM) C MODGEN : (1=DIRECT,2=ITERATIF,3=ITERATIF+REGULARISATION) C SINON C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C ISUI(I) : TYPE DE LA SUITE I (1=GEOMETRIQUE, 2 = ARITHMETIQUE) C FSUI((I-1)*2+1) : VALEUR INITIALE DE LA SUITE I C FSUI((I-1)*2+2) : RAISON DE LA SUITE I C NBSUI : NOMBRE DE SUITES C IDEN((I-1)*4+1) : TYPE DE CONCENTRATION (1=PONCTUELLE,2=AXIALE) C IDEN((I-1)*4+2) : NUMERO DE LA DENSITE (INUTILISE) C IDEN((I-1)*4+3) : NUMERO DU 1IER POINT C IDEN((I-1)*4+4) : NUMERO DU 2IEME POINT (SI CONCENTRATION AXIALE) C COORD() : TABLEAU DES COORDONNEES DES POINTS C NBPT : NOMBRE TOTAL DES POINTS C NBDEN : NOMBRE DE DENSITES C MODGEN : (1=DIRECT,2=ITERATIF,3=ITERATIF+REGUL.) C C C *************************************************************** INTEGER IACTIO CHARACTER*(*) NOM REAL COORD(*) INTEGER IDIMC,NBPT,NBPTMX INTEGER ISUI(*),NBSUI,NBSUMX REAL FSUI(*) INTEGER IDEN(*),NBDEN,NBDNMX,MODGEN,IERR C INTEGER IOLDFI,IFORFI,IUNITC,ISCRFI,IUNIT,NBLC INTEGER I,J,NUMSUI,NUMPT,NUMDEN,ITYPE,NBREF INTEGER ITBNUM(4),NBRFMX,IERR2 REAL XYZ(3),TAILLE,RAISON C INTEGER NUSUMX, NUPOMX, NUDEMX CHARACTER*256 MESSAG C NBPT = 0 NUPOMX = 0 NBSUI = 0 NUSUMX = 0 NBDEN = 0 NUDEMX = 0 MODGEN = 0 C NBRFMX = 4 IERR = -1 IOLDFI = 1 ISCRFI = 2 IFORFI = 0 CALL GESFIC('O',NOM,IOLDFI,IFORFI,IUNITC,IERR) IF( IERR.NE. 0 )GOTO 908 CALL GESFIC('O',' ',ISCRFI,IFORFI,IUNIT,IERR) IF( IERR.NE.0 ) GOTO 908 C ==================================== C --- LECTURE DES POINTS ET DES VECTEURS ----------------- C ==================================== C --- ON ENLEVE LES COMMENTAIRES DU BLOC --- CALL GESCOM(IUNITC,'DEBGEO',6,'FINGEO',6,'*',IUNIT,NBLC,IERR) IF(IERR.NE.0)GOTO 909 REWIND IUNITC REWIND IUNIT IERR = -1 C --- LECTURE DU CORPS ----------------- NUPOMX = 0 READ(IUNIT,*,ERR=910,END=910) NBPT, IDIMC IF((IDIMC.LT.1 ).OR.(IDIMC.GT.3))GOTO 910 DO 10 I=1,NBPT READ(IUNIT,*,ERR=911,END=911) NUMPT,(XYZ(J),J=1,IDIMC) IF( IACTIO.EQ. 0 )THEN NUPOMX = MAX( NUMPT,NUPOMX ) GOTO 10 ENDIF IF( NUMPT.GT.NBPTMX )THEN IERR = -2 GOTO 9999 ENDIF DO 9 J=1,IDIMC COORD((NUMPT-1)*IDIMC+J) = XYZ(J) 9 CONTINUE 10 CONTINUE C =================== C --- LECTURE DES SUITES ------------------ C =================== REWIND IUNIT CALL GESCOM(IUNITC,'DEBSUI',6,'FINSUI',6,'*',IUNIT,NBLC,IERR) IF(IERR.NE.0)GOTO 912 REWIND IUNIT C C --- LECTURE DU CORPS ----------------- READ(IUNIT,*,ERR=913,END=913) NBSUI NUSUMX = 0 DO 20 I=1,NBSUI READ(IUNIT,*,ERR=914,END=914) NUMSUI,ITYPE,TAILLE,RAISON IF( IACTIO.EQ. 0 )THEN NUSUMX = MAX( NUMSUI,NUSUMX ) GOTO 20 ENDIF IF( NUMSUI.GT. NBSUMX )THEN IERR = -2 GOTO 9999 ENDIF ISUI(NUMSUI) = ITYPE FSUI((NUMSUI-1)*2+1) = TAILLE FSUI(NUMSUI*2)= RAISON 20 CONTINUE C =========================== C --- LECTURE DES DENSITES ----------------- C =========================== C --- ON ENLEVE LES COMMENTAIRES DU BLOC --- REWIND IUNIT CALL GESCOM(IUNITC,'DEBDEN',6,'FINDEN',6,'*',IUNIT,NBLC,IERR) IF(IERR.NE.0)GOTO 915 REWIND IUNIT C C --- RECHERCHE D'UN ENTETE ------------- C IERR = 0 C 30 READ(IUNIT,' (A)',ERR=888,END=888) LNG C CALL MAJUSC(6,LNG) C IF(LNG(:6).NE.'DEBDEN')GOTO 30 IERR = -1 C C --- LECTURE DU CORPS ----------------- READ(IUNIT,*,ERR=916,END=916) NBDEN, MODGEN NUDEMX = 0 DO 40 I=1,NBDEN READ(IUNIT,*,ERR=917,END=917) > NUMDEN,ITYPE,NBREF,(ITBNUM(J),J=1,NBREF) IF( IACTIO.EQ. 0 )THEN NUDEMX = MAX( NUMDEN,NUDEMX ) GOTO 40 ENDIF IF( NUMDEN.GT. NBDNMX )THEN IERR = -2 GOTO 9999 ENDIF IDEN((NUMDEN-1)*NBRFMX+1)=ITYPE CALL VDENTI(1,NBREF,ITBNUM,IDEN((NUMDEN-1)*NBRFMX+2)) 40 CONTINUE C --- FIN ET FERMETURES --- IERR = 0 GOTO 9995 C --------------------------------------------- C --- NOUVEAU TRAITEMENT DES ERREURS (UTILISATEUR)--- C --------------------------------------------- CALL ESMESS(IERR,14,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) 908 IERR =-1 CALL ESMESS(IERR,14,1,'IMPOSSIBLE D OUVRIR LE FICHIER',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9999 909 CONTINUE CALL ESMESS(IERR,46,1,'DEBUT, FIN DU BLOC GEO MANQUANT',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9995 910 IERR = -1 CALL ESMESS(IERR,47,1,'NOMBRE DE POINTS OU DIM INVALIDE',MESSAG) CALL ESECHA(1,MESSAG,NOM) GOTO 9995 911 IERR = -1 CALL ESMESS(IERR,48,1,'AU POINT',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 9995 C 912 CONTINUE CALL ESMESS(IERR,49,1,'DEBUT, FIN DU BLOC SUI MANQUANT',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 913 IERR = -1 CALL ESMESS(IERR,50,1,'NOMBRE DE SUITE INVALIDE',MESSAG) CALL ESEINT(1,MESSAG,NBSUI,1) GOTO 9995 914 IERR = -1 CALL ESMESS(IERR,51,1,'A LA LECTURE DE LA SUITE',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 9995 C 915 CONTINUE CALL ESMESS(IERR,52,1,'DEBUT, FIN DU BLOC DEN MANQUANT',MESSAG) CALL ESECHA(1,MESSAG,' ') GOTO 9995 916 IERR = -1 CALL ESMESS(IERR,53,1,'NOMBRE DE CONCENTRATIONS INVALIDE',MESSAG) CALL ESEINT(1,MESSAG,NBDEN,1) GOTO 9995 917 IERR = -1 CALL ESMESS(IERR,54,1,'A LA LECTURE DE LA DENSITE : ',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 9995 C 9995 CALL GESFIC('F',NOM,IOLDFI,IFORFI,IUNITC,IERR2) CALL GESFIC('F',' ',IOLDFI,IFORFI,IUNIT,IERR2) IF( IACTIO.EQ.0 )THEN NBPT = NUPOMX NBSUI = NUSUMX NBDEN = NUDEMX ENDIF 9999 END C C SUBROUTINE STRDEN(IDENS,COORD,IDIMC,NBPT, > ISUI,FSUI,NBSUI,IDEN,NBDEN, > ITYPSU,RAISON,TAILLE,ITYPDN,XPTDEN,IERR) C *************************************************************** C OBJET STRDEN : CONSTRUIT LES FONCTIONS DE DENSITE C C EN ENTREE : C IDENS : NUMERO DE LA DENSITE A LIRE C --- LOCALISATION DES CONCENTRATIONS ---- C COORD : C IDIMC : C NBPT : C --- SUITE DEFINISSANT LA PROGRESSION --- C ISUI : NUMERO C FSUI : C NBSUI : C --- DEFINITION DE LA DENSITE ----------- C IDEN : C NBDEN : C C EN SORTIE : C ITYPSU,RAISON,TAILLE,ITYPDN,XPTDEN : LES INFO DE DENSITE C *************************************************************** REAL COORD(*) INTEGER IDENS,IDIMC,NBPT INTEGER ISUI(*),NBSUI REAL FSUI(*), RAISON,TAILLE INTEGER IDEN(*),NBDEN INTEGER ITYPSU,ITYPDN,IERR REAL XPTDEN(*) C INTEGER NUMPT,I,J,NUMSUI,NBPODN CHARACTER*256 MESSAG C IERR = -1 IF((IDENS .GT. NBDEN).OR.(IDENS.LE.0))GOTO 901 C NUMSUI = IDEN((IDENS-1)*4+2) IF((NUMSUI.GT.NBSUI).OR.(NUMSUI.LE.0))GOTO 902 ITYPSU = ISUI(NUMSUI) RAISON = FSUI((NUMSUI-1)*2+2) TAILLE = FSUI((NUMSUI-1)*2+1) GOTO (10,20) ITYPSU C --- SUITE GEOMETRIQUE --- 10 CONTINUE IF( RAISON .LE. 0 )GOTO 903 IF( TAILLE .LE. 0 )GOTO 904 GOTO 50 20 CONTINUE IF((RAISON.LE.0).AND.(TAILLE.LE.0))GOTO 905 50 CONTINUE C ITYPDN = IDEN((IDENS-1)*4+1) GOTO (110,120,130) ITYPDN GOTO 906 C ---- CONCENTRATION PONCTUELLE ---- 110 CONTINUE NBPODN = 1 GOTO 150 C ---- CONCENTRATION SUR UNE DROITE ---- 120 CONTINUE NBPODN = 2 GOTO 150 C ---- CONCENTRATION SUR UNE SEGMENT ---- 130 CONTINUE NBPODN = 2 GOTO 150 150 CONTINUE C DO 310 I=1,NBPODN NUMPT = IDEN((IDENS-1)*4+2+I) IF((NUMPT.GT.NBPT).OR.(NUMPT.LE.0))GOTO 907 DO 300 J=1,IDIMC XPTDEN((I-1)*IDIMC+J) = COORD((NUMPT-1)*IDIMC+J) 300 CONTINUE 310 CONTINUE IERR = 0 GOTO 9999 C ---- messages d'erreur ---- 901 IERR=-1 CALL ESMESS(IERR,55,1,'NUMERO DE CONCENTRATION',MESSAG) CALL ESEINT(1,MESSAG,IDENS,1) GOTO 9999 902 IERR=-1 CALL ESMESS(IERR,56,1,'NUMERO DE LA SUITE',MESSAG) CALL ESEINT(1,MESSAG,NUMSUI,1) GOTO 9999 903 IERR=-1 CALL ESMESS(IERR,57,1,'RAISON NEGATIVE OU NULLE',MESSAG) CALL ESEREA(1,MESSAG,RAISON,1) GOTO 9999 904 IERR=-1 CALL ESMESS(IERR,58,1,'TAILLE NEGATIVE OU NULLE',MESSAG) CALL ESEREA(1,MESSAG,TAILLE,1) GOTO 9999 905 IERR=-1 CALL ESMESS(IERR,59,1,'TAILLE & RAISON NEGATIVE OU NULLE',MESSAG) CALL ESEREA(1,MESSAG,RAISON,1) GOTO 9999 906 IERR=-1 CALL ESMESS(IERR,60,1,'TYPE DE CONCENTRATION INCONNUE',MESSAG) CALL ESEINT(1,MESSAG,ITYPDN,1) GOTO 9999 907 IERR=-1 CALL ESMESS(IERR,61,1,'REFERENCE AU POINT INCORRECTE',MESSAG) CALL ESEINT(1,MESSAG,NUMPT,1) C 9999 END C SUBROUTINE DEFDEN(MODGEN,IADEC,NIADEC,RADEC,NRIDEC,NBFDEC) C *************************************************************** C OBJET DEFDEN : DEFINIE LA DENSITE PAR DEFAUT C C EN ENTREE : C EN SORTIE : C MODGEN : 1 (DEFAUT) C C IADEC((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RADEC((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C NRIDEC : NOMBRE MAX. DE PARAMETRES REELS C NBFDEC : NOMBRE DE RAFFINEMENTS C C IADEC(1) = 1 C RADEC(2) = 1.1 C NIADEC = 2 C IRIDEC = 6 C NBFDEC = 1 C C *************************************************************** INTEGER MODGEN,IADEC(*),NIADEC,NRIDEC,NBFDEC REAL RADEC(*) C IADEC(1) = 1 RADEC(2) = 1.1 MODGEN = 1 NIADEC = 2 NRIDEC = 6 C NBFDEC = 0 C --- REMPLACER PAR : NBFDEC = 1 END C C C SUBROUTINE INIDEN(IACTIO,NOM,MODDEF,MODGEN, > IADEC,NIADEC,RADEC,IRIDEC, > NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX, > ITRACE,IERR) C *************************************************************** C OBJET INIDEN : INITIALISE LES DENSITES (A PARTIR D'UN FICHIER) C C EN ENTREE : C IACTIO : 0 RENVOI LES TAILLES NECESSAIRES C 1 REMPLI LES TABLEAUX C NOM : NOM DU FICHIER DE DEFINITION DE LA DENSITE C NDECMX : - INUTILISE - C C EN SORTIE : C MODDEF : LA DEFINITION DE LA DENSITE PEUT ETRE INCOMPLETE C 0 NON DEFINI (ERREUR) C 1 INCOMPLET (UNE SUITE SEULEMENT) C 2 COMPLET (UNE CONCENTRATION) C MODGEN : MODE DE GENERATION DES NOEUDS C 0 NON DEFINI C 1 DIRECT C 2 ITERATIF C 3 ITERATIF + LISSAGE C C IADEC((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RADEC((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C IRIDEC : NOMBRE MAX. DE PARAMETRES REELS C NBFDEC : NOMBRE DE RAFFINEMENTS C C IERR : 0 SI OK C -1 SI LA LECTURE DU FICHIER A PROVOQUE UNE ERREUR C -2 SI ON A PAS IL Y A TROP DE DENSITE, DE SUITES... C C *************************************************************** INTEGER IACTIO INTEGER IADEC(*),NIADEC,IRIDEC,MODDEF,MODGEN INTEGER NBFDEC,NDECMX,ITVL(*),NITMAX,NRTMAX REAL RADEC(*), RTVL(*) INTEGER ITRACE,IERR CHARACTER*(*) NOM C INTEGER NBSUMX,NBDNMX,NBPTMX INTEGER NBSUI,NBPT,IDIMC,I,ITZERO(1) INTEGER IDEN,ISUI,ICOORD,IFSUI REAL RSGMAX,RSAMAX REAL TRZERO(1) CHARACTER*256 MESSAG C TRZERO(1) = 0.0 ITZERO(1) = 0 MODDEF = 0 MODGEN = 0 C ========================= C --- 1.LECTURE DE LA DENSITE --- C ========================= NIADEC = 2 C --- TAILLE, RAISON, 2PT IRIDEC = 6 NBFDEC = 0 C --- LECTURE DES TAILLES NECESSAIRES --- CALL LITDEN(0,NOM,TRZERO,IDIMC,NBPT,0, > ITZERO,TRZERO,NBSUI,0,ITZERO,NBFDEC,0,MODGEN,IERR) IF( IERR .NE. 0 )GOTO 999 IF( NBFDEC .LE. 0 )THEN MODDEF = 1 ELSE MODDEF = 2 ENDIF IF(IACTIO.EQ.0)GOTO 999 C LE FICHIER EXISTE ET A UN FORMAT CORRECT MAIS NE CONTIENT C NI SUITE NI DENSITE IF((NBFDEC .LE. 0 ).AND.( NBSUI.EQ. 0 ))THEN MODDEF = 1 MODGEN = 1 IADEC(1) = 1 RADEC(2) = 1.1 IF( ITRACE.GT. 0 )THEN CALL ESMESS(0,62,1,'PAS DE CONCENTRATION',MESSAG) CALL ESECHA(1,MESSAG,' ') ENDIF GOTO 999 ENDIF C --- ALLOCATION ET LECTURE REELLE ---- NBPTMX = NBPT NBDNMX = NBFDEC NBSUMX = NBSUI C ISUI = 1 IDEN = NBSUMX + ISUI ICOORD = 1 IFSUI = NBPTMX * IDIMC + ICOORD IF(( NITMAX.LT. (NBDNMX*4 + NBSUMX)).OR. > ( NRTMAX.LT. (NBPTMX*IDIMC + 2*NBSUMX)))THEN IERR = -2 GOTO 999 ENDIF C CALL LITDEN(1,NOM,RTVL(ICOORD),IDIMC,NBPT,NBPTMX, > ITVL(ISUI),RTVL(IFSUI),NBSUI,NBSUMX, > ITVL(IDEN),NBFDEC,NBDNMX,MODGEN,IERR) C C LE FICHIER EXISTE ET A UN FORMAT CORRECT MAIS NE CONTIENT C PAS DE DENSITE, SEULEMENT UNE SUITE IF(( NBFDEC .LE. 0 ).AND.( NBSUI.EQ. 1 ))THEN MODDEF = 1 MODGEN = 1 IADEC(1) = ITVL(ISUI) RADEC(2) = RTVL(IFSUI+1) IF( ITRACE.GT. 0 )THEN CALL ESMESS(0,62,1,'PAS DE CONCENTRATION',MESSAG) CALL ESECHA(1,MESSAG,' ') ENDIF GOTO 999 ENDIF C ============================ C --- 2.TRANSFORMATION DU FORMAT --- C ============================ IF( ITRACE.GT. 0 )THEN CALL ESMESS(101,6,1,'NOMBRE DE CONCENTRATION',MESSAG) CALL ESEINT(1,MESSAG,NBFDEC,1) CALL ESMESS(101,7,1,'MODE DE GENERATION',MESSAG) CALL ESEINT(1,MESSAG,MODGEN,1) ENDIF MODDEF = 2 C RSGMAX = 0.0 RSAMAX = 0.0 DO 10 I=1,NBFDEC CALL STRDEN(I,RTVL(ICOORD),IDIMC,NBPT, > ITVL(ISUI),RTVL(IFSUI), > NBSUI,ITVL(IDEN),NBFDEC, > IADEC((I-1)*NIADEC+1),RADEC((I-1)*IRIDEC+1), > RADEC((I-1)*IRIDEC+2),IADEC((I-1)*NIADEC+2), > RADEC((I-1)*IRIDEC+3),IERR) C IF( IERR .NE. 0 )THEN CALL ESMESS(IERR,54,1,'A LA CONCENTRATION ',MESSAG) CALL ESEINT(1,MESSAG,I,1) GOTO 999 ENDIF IF( IADEC((I-1)*NIADEC+1).EQ. 1 )THEN RSGMAX = MAX(RSGMAX,RADEC((I-1)*IRIDEC+1)) ELSE RSAMAX = MAX(RSAMAX,RADEC((I-1)*IRIDEC+1)) ENDIF 10 CONTINUE C --- ON CALCUL LA RAISON MAXIMUM --- IF(RSGMAX.EQ.0)THEN IADEC(NBFDEC*NIADEC+1) = 2 RADEC(NBFDEC*IRIDEC+1) = RSAMAX ELSE IADEC(NBFDEC*NIADEC+1) = 1 RADEC(NBFDEC*IRIDEC+1) = RSGMAX ENDIF C ---- POUR LA CONVERGENCE (REGULARISATION LISSAGE) ------ IF(MODGEN.EQ.3)RADEC(NBFDEC*IRIDEC+2) = 0.05 C 999 END C C *************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_RAFFINE.F C OBJET ES_RAFFINE.F : LECTURE DES INFORMATIONS POUR LE RAFFINEMENT C C FONCT. : C OBJET LITRAF : LIT LES INFOS POUR LE RAFFINEMENT C C FONCT. LOCALES : C OBJET LITTSN : LIT LA DENSITE (VALEURS NODALES) C OBJET TYFIDE : DONNE LE TYPE DU FICHIER DE DENSITE C C AUTEUR : O. STAB C DATE : 05.98 C C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 8/4/2002, suppression de ARGRAF C suppr ARGRAF : ARGUMENTS DES PROGRAMMES DE RAFFINEMENT C AUTEUR, DATE, OBJET : O.STAB, 8/4/2002,remp. de DSERRE par ESERRO C AUTEUR, DATE, OBJET : O.STAB, 20.09.2004, AJOUT TYFIDE C *************************************************************** C SUBROUTINE TYFIDE(NOM,ITYPRA,IERR) C *************************************************************** C OBJET TYFIDE : DONNE LE TYPE DU FICHIER DE DENSITE INTEGER ITYPRA,IERR CHARACTER*(*) NOM C INTEGER IOLDFI,IFORFI,IUNITC,NBLC,IERR2 ITYPRA =-1 IOLDFI = 1 IFORFI = 0 CALL GESFIC('O',NOM,IOLDFI,IFORFI,IUNITC,IERR) IF( IERR.NE. 0 )GOTO 9999 CALL GESCOM(IUNITC,'DEBGEO',6,'FINGEO',6,'*',0,NBLC,IERR) C FICHIER DENSITE IF(IERR.EQ.0)THEN ITYPRA = 1 GOTO 9995 ENDIF IERR = 0 REWIND IUNITC CALL GESCOM(IUNITC,'DEBGRD',6,'FINGRD',6,'*',0,NBLC,IERR) C FICHIER GRANDEURS IF(IERR.EQ.0)THEN ITYPRA = 2 GOTO 9995 ENDIF ITYPRA =-1 9995 CALL GESFIC('F',NOM,IOLDFI,IFORFI,IUNITC,IERR2) 9999 END C C SUBROUTINE LITTSN(IACTIO,NOM,MODGEN, > IADEC,NIADEC,RADEC,NRIDEC, > NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX, > ITRACE,IERR) C *************************************************************** C OBJET LITTSN : LIT LA DENSITE (VALEURS NODALES) C C EN ENTREE : C IACTIO : 0 RENVOI LES TAILLES NECESSAIRES C 1 REMPLI LES TABLEAUX C NOM : NOM DU FICHIER DE DEFINITION DE LA DENSITE C NDECMX : TAILLE DU TABLEAU RADEC C C EN SORTIE : C MODGEN : MODE DE GENERATION DES NOEUDS C 0 NON DEFINI C 1 DIRECT C 2 ITERATIF C 3 ITERATIF + LISSAGE C C IADEC((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS (= 0) C C RADEC((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C RADEC(I) : VALEUR DE LA TAILLE SOUHAITEE AU NOEUD I (CAS ISOTROPE) C NRIDEC : NOMBRE MAX. DE PARAMETRES REELS = NBN C NBFDEC : NOMBRE DE RAFFINEMENTS (= 1 CAS ISOTROPE) C *************************************************************** INTEGER IACTIO INTEGER IADEC(*),NIADEC,NRIDEC,MODGEN INTEGER NBFDEC,NDECMX,ITVL(*),NITMAX,NRTMAX REAL RADEC(*), RTVL(*) INTEGER ITRACE,IERR CHARACTER*(*) NOM C REAL ZERO INTEGER NBN,IDIMC,NRGMAX CHARACTER*256 MESSAG C ZERO = 0.0 NRGMAX = 0 CALL LITGRD(0,NOM,0,ZERO,IDIMC,NBN,IERR) IF( IERR.NE.0 )GOTO 9999 IF(IDIMC.NE.1)GOTO 901 NIADEC = 0 NBFDEC = IDIMC NRIDEC = NBN C MODGEN = 2 C REMPLACE PAR (MODGEN N'EST PAS DEFINIT : EN 1D DIRECT, EN 2D ITERATIF): MODGEN = -1 IF(IACTIO.EQ.0)GOTO 9999 CALL LITGRD(IACTIO,NOM,NRTMAX,RADEC,IDIMC,NBN,IERR) IF( IERR.NE.0 )GOTO 901 GOTO 9999 C --- messages d'erreur 901 IERR=-1 CALL ESMESS(IERR,41,1,'DIMENSION DOIT ETRE DE 1 ',MESSAG) CALL ESEINT(1,MESSAG,IDIMC,1) 9999 END C SUBROUTINE LITRAF(IACTIO,NOM,MODDEF,MODGEN, > IADEC,NIADEC,RADEC,NRADEC,NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C *************************************************************** C OBJET LITRAF : LIT LES INFOS POUR LE RAFFINEMENT C C EN ENTREE : C IACTIO : 0 RENVOI LES TAILLES NECESSAIRES C 1 REMPLI LES TABLEAUX C NOM : NOM DU FICHIER DE DEFINITION DE LA DENSITE C C EN SORTIE : C MODDEF : MODE DE DEFINITION DES DENSITES C 0 NON DEFINI C 1 DEFAUT (AMORTISSEMENT EN 1D : UNE SUITE) C 2 FONCTIONS ANALYTIQUES SPATIALES (X,Y) C 3 TAILLES SOUHAITEES AUX NOEUDS + INTERPOLATION C MODGEN : MODE DE GENERATION DES NOEUDS C 0 NON DEFINI C 1 DIRECT C 2 ITERATIF C 3 ITERATIF + LISSAGE C C IADEC((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RADEC((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C NRADEC : NOMBRE MAX. DE PARAMETRES REELS C NBFDEC : NOMBRE DE RAFFINEMENTS C C REMARQUE : dans la librairie mais devrait etre avec l'application C *************************************************************** INTEGER IACTIO INTEGER IADEC(*),NIADEC,NRADEC,MODDEF,MODGEN INTEGER NBFDEC,NDECMX,ITVL(*),NITMAX,NRTMAX REAL RADEC(*), RTVL(*) INTEGER ITRACE,IERR CHARACTER*(*) NOM C REAL ZERO INTEGER MODDEN,ITYPRA CHARACTER*256 MESSAG C MODDEF = 0 MODGEN = 0 ZERO = 0.0 IF( NOM .EQ. ' ' )THEN C ======================== C --- PAS DE FICHIER DENSITE --- C ======================== IF( ITRACE .NE. 0 )THEN CALL ESMESS(101,2,1,'-> DENSITE PAR DEFAUT ',MESSAG) CALL ESECHA(1,MESSAG,' ') ENDIF IF( IACTIO .EQ. 0 )THEN CALL DEFDEN(MODGEN,ITVL,NIADEC,RTVL,NRADEC,NBFDEC) ELSE CALL DEFDEN(MODGEN,IADEC,NIADEC,RADEC,NRADEC,NBFDEC) ENDIF MODDEF = 1 GOTO 9999 ENDIF C ======================== C --- 1.LECTURE DE LA DENSITE --- C ======================== IF( ITRACE .NE. 0 )THEN CALL ESMESS(101,3,1,'-> LECTURE DES DENSITES :',MESSAG) CALL ESECHA(1,MESSAG,' ') ENDIF C C AJOUT 20.09.2004 ON TESTE LE TYPE DE FICHIER CALL TYFIDE(NOM,ITYPRA,IERR) GOTO (100,200) ITYPRA GOTO 9999 C 100 CONTINUE C ================================ C --- DENSITE = FONCTION ANALYTIQUES --- C =============================== IF( ITRACE .NE. 0 )THEN CALL ESMESS(101,4,1,'-> FONCTIONS DE DENSITES :',MESSAG) CALL ESECHA(1,MESSAG,' ') ENDIF CALL INIDEN(0,NOM,MODDEN,MODGEN,0,NIADEC, > ZERO,NRADEC, > NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX, > ITRACE,IERR) IF( IERR .NE. 0 )GOTO 9999 C - SI LA DEFINITION EST INCOMPLETE (UNE SUITE) => MODDEF = DEFAUT - IF( MODDEN.EQ. 1 )MODDEF = 1 C - SI LA DEFINITION EST ICOMPLETE (UNE DENSITE) => MODDEF = ANALYTIQUE - IF( MODDEN.EQ. 2 )MODDEF = 2 IF( IACTIO .EQ. 0 )GOTO 9999 CALL INIDEN(1,NOM,MODDEN,MODGEN,IADEC,NIADEC, > RADEC,NRADEC, > NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX, > ITRACE,IERR) IF( IERR .NE. 0 )THEN CALL ESERRE(1,IERR,'LITRAF',' APPEL INIDEN') ENDIF GOTO 9999 C ========================== C --- DENSITE DONNEE AU NOEUDS --- C ========================== 200 CONTINUE IF( ITRACE .NE. 0 )THEN CALL ESMESS(101,5,1,'-> VALEURS NODALES :',MESSAG) CALL ESECHA(1,MESSAG,' ') ENDIF CALL LITTSN(0,NOM,MODGEN,0,NIADEC, > ZERO,NRADEC, > NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX, > ITRACE,IERR) IF( IERR .NE. 0 )THEN CALL ESERRE(1,IERR,'LITRAF','APPEL LITTSN OU INIDEN') GOTO 9999 ENDIF MODDEF = 3 IF( IACTIO .EQ. 0 )GOTO 9999 CALL LITTSN(1,NOM,MODGEN,IADEC,NIADEC, > RADEC,NRADEC, > NBFDEC,NDECMX, > ITVL,NITMAX,RTVL,NRTMAX, > ITRACE,IERR) IF( IERR .NE. 0 )THEN CALL ESERRE(1,IERR,'LITRAF',' APPEL LITTSN') ENDIF C 9999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_REQUETE.F C OBJET : LECTURE DE REQUETES C FONCT. : C LITREQ : LECTURE DE REQUETES SUR UN MAILLAGE C C AUTEUR : O.STAB C DATE : 02.96 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 16.08.98, PASSAGE ANSI. C C C ***************************************************************** C C SUBROUTINE LITREQ(IACTIO,NOM,NOEREQ,NBMXRQ, > IMATRQ,IREFRQ,NBREQ,IERR) C ***************************************************************** C OBJET LITREQ : LECTURE DES REQUETES DANS LE FICHIER NOM C SYNTAXE : { NOEUDS } REFERENCE REGION C C EN ENTREE : C IACTIO : ENTIER INDIQUANT AU S/PROGRAMME LES ENTITES A LIRE C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C DE PLUS, SI IACTIO > 0 : C NBMXRQ : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C C EN SORTIE : C IERR=0 : PAS D'ERREUR C IERR=-1 : PROBLEME D'OUVERTURE DU FICHIER C C SI IACTIO = 0 CALL LITREQ(0,NOMREQ,0,NBMXRQ,0,0,NBREQ,IERR) C IDIMC,NBN,0.,IDE,NBNMAX,NBE,0,NMT,REFMAT,0,IERR) C NBMXRQ : NB MAXI DE NOEUDS PAR REQUETE C NBREQ : NOMBRE TOTAL DE REQUETES C C SI IACTIO = 1 C NBREQ : NOMBRE TOTAL DE REQUETES C NOEREQ : NOEUD DE LA REQUETE C IMATRQ : MATERIAU OU REGION DE LA REQUETE C IREFRQ : REFERENCE DE LA REQUETE C C ***************************************************************** CHARACTER*(*) NOM INTEGER IACTIO,NOEREQ(*),NBMXRQ,IMATRQ(*),IREFRQ(*),NBREQ INTEGER IERR C INTEGER IN,IT,N,I,J,IEL,MM,NEL,M,IC,IM,L(27) INTEGER LENCHR,NBLC C NBREQ = 0 IF( IACTIO.EQ. 0 )NBMXRQ = 0 C CALL GESFIC('O',NOM,1,0,IN,IERR) CALL GESFIC('O',' ',2,0,IT,I) IF(IERR.NE.0.OR.I.NE.0) GOTO 80 CALL GESCOM(IN,'DEBREQ',6,'FINREQ',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)GOTO 80 REWIND IN REWIND IT C C ====================================== C --- 1. LECTURE DES REQUETES --- C ====================================== C READ(IT,*,ERR=80,END=80) NBREQ IF(NBREQ.LE.0) GOTO 80 C --- IL FAUT AU MOINS UNE REQUETE ! IF(IACTIO.EQ.0) THEN DO 10 I=1,NBREQ READ(IT,*,ERR=80,END=80) N NBMXRQ = MAX( NBMXRQ,N) 10 CONTINUE GOTO 95 ENDIF IF( NBMXRQ.LT. 0 )THEN IERR = -1 GOTO 95 ENDIF DO 20 I=1,NBREQ READ(IT,*,ERR=80,END=80) > N,(NOEREQ((I-1)*NBMXRQ+J),J=1,N), > IREFRQ(I),IMATRQ(I) DO 15 J=N+1,NBMXRQ NOEREQ((I-1)*NBMXRQ+J) = 0 15 CONTINUE IF( N.GT. NBMXRQ )GOTO 90 20 CONTINUE GOTO 95 C --- TRAITEMENT DES ERREURS --- 80 IERR=-1 GOTO 95 90 IERR=-2 C --- FIN --- 95 CALL GESFIC('F',' ',0,0,IN,I) CALL GESFIC('F',' ',0,0,IT,I) 999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_ENSEMBLE.F C OBJET : ECRITURE DES ENSEMBLES C FONCT. : C ECRENS : ECRITURE DES ENSEMBLES DANS LE FICHIER NOM DU TYPE C VIPLEF3D C C AUTEUR : O.STAB C DATE : 02.96 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 160898, BUG DANS ECRENS ?! C C C ***************************************************************** C C SUBROUTINE ECRENS(NOM,IDE,ITRNOE,NBNMAX, > IENS,IREF,IDENS, NBENS, IELEMENS,IERR ) C ***************************************************************** C OBJET ECRENS : ECRITURE DES ENSEMBLES DANS UN FICHIER C C EN ENTREE : C NOM : NOM DU FICHIER A OUVRIR, REMPLIR PUIS FERMER C --- LE MAILLAGE --- C IDE : DIMENSION DES ELEMENTS DU MAILLAGE C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C ITRNOE : TABLEAU DES ELEMENTS C --- LES ENSEMBLES --- C IENS : C IREF : IREF(I) = REFERENCE DE L'ENSEMBLE I C IDENS : IDENS(I) = TYPE DES ELEMENTS DE L'ENSEMBLE I C IDE <=> MAILLES, 0 <=> SOMMET, 1 <=> ARETE C 2 <=> FACETTE C NBENS : NOMBRE D'ENSEMBLE C IELEMENS : LES ELEMENTS DES ENSEMBLES SOUS LA FORME DE DOUBLETS C (E,A) : E EST L'ELEMENT, A L'ADRESSE RELATIVE DE C L'ENTITE RECHERCHEE DANS L'ELEMENT E C C C EN SORTIE : C IER= 0 : PAS D'ERREUR C IER=-1 : PROBLEME D'OUVERTURE DU FICHIER C C ***************************************************************** CHARACTER*(*) NOM INTEGER IDE,ITRNOE(*),NBNMAX INTEGER IENS(*),IREF(*),IDENS(*), NBENS, IELEMENS(*),IERR C INTEGER IUNIT,I,J INTEGER IDEBUT,IFIN,NUM,IT,IR,IAR,IARS,N1,N2,NBNE INTEGER STRNBN EXTERNAL STRNBN C C --- MODIF O.STAB 28.05.98 : ON DOIT POUVOIR ECRIRE DANS UN C FICHIER EXISTANT C C IERR = GESFICTEST(NOM,0,0) C IF( IERR.NE.0 )THEN C C ON AJOUTE EN FIN SI LE FICHIER EXISTE C C CALL GESFIC('O',NOM,1,0,IUNIT,IERR) C C'EST UN NOUVEAU FICHIER !!! BUG160898 O.STAB CALL GESFIC('O',NOM,0,0,IUNIT,IERR) IF( IERR.NE. 0 )GOTO 999 C MODIF DU 16.10.2000 O.STAB : BOUCLE INFINIE SUR IRIX6.5 C 10 READ(IUNIT,*,ERR=11,END=11) C GOTO 10 11 WRITE(IUNIT,'(A)')'* AJOUT DES ENSEMBLES' C ELSE C CALL GESFIC('O',NOM,0,0,IUNIT,IERR) C IF( IERR.NE. 0 )GOTO 999 C ENDIF C C I. ECRITURE DES ENSEMBLES C ------------------------- WRITE(IUNIT,'(A)')'DEBENS' WRITE(IUNIT,*) IENS(NBENS) C C --- BOUCLE SUR LES ENSEMBLES --- C IDEBUT = 1 NUM = 0 NBNE = NBNMAX DO 50 I=1,NBENS IR = IREF(I) IFIN = IENS(I) C ================= C --- POUR LES ELEMENTS (D'UNE REGION) --- C ================= IF( IDENS(I).EQ.IDE )THEN DO 20 J=IDEBUT,IFIN IT = IELEMENS((J-1)*2+1) NUM = NUM + 1 WRITE(IUNIT,*) '0 ',IT,IR,NUM 20 CONTINUE C ================= C --- POUR LES ELEMENTS (INCIDENT A UN NOEUD) --- C ================= ELSE IF( IDENS(I).EQ.0 )THEN DO 30 J=IDEBUT,IFIN IT = IELEMENS((J-1)*2+1) IAR = IELEMENS((J-1)*2+2) N1 = ITRNOE((IT-1)*NBNMAX+IAR) NUM = NUM + 1 WRITE(IUNIT,*) '1 ',N1,IT,IR,NUM 30 CONTINUE ELSE C ================= C --- POUR LES NOEUDS (DES ARETES) --- C ================= IF( IDENS(I).EQ.1 )THEN DO 40 J=IDEBUT,IFIN IT = IELEMENS((J-1)*2+1) IAR = IELEMENS((J-1)*2+2) IF( NBNMAX.NE.3 )NBNE = STRNBN(IT,ITRNOE,NBNMAX) N1 = ITRNOE((IT-1)*NBNMAX+IAR) IARS = MOD(IAR,NBNE)+1 N2 = ITRNOE((IT-1)*NBNMAX+IARS) NUM = NUM + 1 WRITE(IUNIT,*) '2 ',N1,N2,IT,IR,NUM 40 CONTINUE ELSE IERR = -3 ENDIF ENDIF ENDIF IDEBUT = IFIN + 1 50 CONTINUE WRITE( IUNIT,'(A)')'FINENS' C 100 CALL GESFIC('F',NOM,3,0,IUNIT,IERR) 999 END C ********************************************************************** C FICHIER : ES_BREP.F C OBJET : LECTURE ECRITURE D'UNE "Brep" (Boundary REPresentation) C FONCT. : C OBJET ESFACE : LECTURE/ECRITURE D'UNE FACE C OBJET ESCOOR : LECTURE/ECRITURE DE COORDONNEES C OBJET ESARET : LECTURE/ECRITURE D'UNE ARETE C OBJET ECRBRP : ECRITURE D'UNE FRONTIERE (BREP) C OBJET LICBRP : LECTURE DES ENTETES D'UN FICHIER BREP (FRONTIERE) C OBJET LICBLC : LECTURE DE L'ENTETE D'UN BLOC C OBJET LITBRP : LECTURE D'UNE BREP (FRONTIERE) C C AUTEUR : O. STAB C DATE : 15.03.2001 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C GESTION DES FICHIERS C UN FICHIER : VERSION (BLOCS)* C UN BLOC : DEBUT VERSION C ENTETE C (ENREGISTREMENT)* C FIN C UN ENREGISTREMENT : (MOTS)* C GESTION DES VERSIONS DE FICHIER C C ********************************************************************** C SUBROUTINE ESFACE(IACTIO,IUNIT,IVERSI, > IFACE,ITVOFA,NBVOFA,NBVOMX, > IERR) C ***************************************************************** C OBJET ESFACE : LECTURE/ECRITURE D'UNE FACE C EN ENTREE : C IACTIO : 0 LECTURE C 1 ECRITURE C IUNIT : -1 STDERR/STDIN (A FAIRE) C 0 STDOUT/STDIN (A FAIRE) C 1..25 FICHIER (RENVOYE PAR GESFIC) C IVERSI : VERSION DU FORMAT C C ***************************************************************** INTEGER IACTIO,IUNIT,IVERSI INTEGER IFACE,ITVOFA(*),NBVOFA,NBVOMX INTEGER IERR C INTEGER J INTEGER MAXVOL PARAMETER (MAXVOL = 10) INTEGER LECVOL(MAXVOL) C IERR = 0 C ------------------------------ C ---- VERIFICATION POUR L'ECRITURE --- C ------------------------------ IF( IACTIO.EQ.1 )THEN IF(NBVOFA.GT.2)THEN IERR = -1 CALL ESERRE(1,IERR,'ESFACE', > ' UNE FACE A PLUS DE 2 VOLUMES ?') PRINT *,'FACE = ',IFACE GOTO 9999 ENDIF ENDIF C ------------------------------ C ---- LECTURE / ECRITURE ---- C ------------------------------ C C IF( IVERSI )GOTO (10,20) IVERSI GOTO (10,20) IVERSI C ---- VERSION INCONNUE ---- IERR = -1 CALL ESERRE(1,IERR,'ESARET', > 'VERSION DU FORMAT DE FACE INCONNU') GOTO 9999 C ---- VERSION 2 ---- IL N'Y A PAS DE VERSION 1 10 CONTINUE 20 CONTINUE IF( IACTIO.EQ.0 )THEN READ(IUNIT,*,ERR=390,END=395)IFACE, > NBVOFA,(LECVOL(J),J=1,MIN(NBVOFA,MAXVOL)) ELSE WRITE(IUNIT,*) IFACE,NBVOFA, > (ITVOFA(J),J=1,NBVOFA) ENDIF GOTO 100 C -------- 100 CONTINUE C ------------------------------ C ---- VERIFICATION POUR LA LECTURE --- C ------------------------------ IF( IACTIO.EQ.1 )GOTO 9999 C IF(NBVOFA.GT.NBVOMX)THEN IERR = -1 CALL ESERRE(1,IERR,'ESFACE', > ' UNE FACE A TROP DE VOLUMES') PRINT *,'FACE = ',IFACE,(LECVOL(J),J=1,NBVOFA) GOTO 9999 ENDIF DO 360 J=1,NBVOFA ITVOFA(J)=LECVOL(J) 360 CONTINUE DO 361 J=NBVOFA+1,NBVOMX ITVOFA(J)=0 361 CONTINUE 380 CONTINUE GOTO 9999 C ----------------------------- C ---- GESTION DES ERREURS DU BLOC ---- C ----------------------------- 390 IERR = -1 CALL ESERRE(1,IERR,'ESFACE', > ' ERREUR LECTURE FACE') PRINT *,'FACE = ',IFACE GOTO 9999 395 IERR = -1 CALL ESERRE(1,IERR,'ESFACE', > ' FACE INCOMPLETE') PRINT *,'FACE = ',IFACE GOTO 9999 C 9999 END C C SUBROUTINE ESCOOR(IACTIO,IUNIT,IVERSI, > ISOMME,COORD,NBNOMX,IDIMC, > IERR) C ***************************************************************** C OBJET ESCOOR : LECTURE/ECRITURE DE COORDONNEES C EN ENTREE : C IACTIO : 0 LECTURE C 1 ECRITURE C IUNIT : -1 STDERR/STDIN (A FAIRE) C 0 STDOUT/STDIN (A FAIRE) C 1..25 FICHIER (RENVOYE PAR GESFIC) C IVERSI : VERSION DU FORMAT C C ***************************************************************** INTEGER IACTIO,IUNIT,IVERSI INTEGER ISOMME,NBNOMX,IDIMC REAL COORD(*) INTEGER IERR C INTEGER J C IERR = 0 C ------------------------------ C ---- VERIFICATION POUR L'ECRITURE --- C ------------------------------ IF( IACTIO.EQ.1 )THEN ENDIF C ------------------------------ C ---- LECTURE / ECRITURE ---- C ------------------------------ C C IF( IVERSI )GOTO (10,20) IVERSI GOTO (10,20) IVERSI C ---- VERSION INCONNUE ---- IERR = -1 CALL ESERRE(1,IERR,'ESCOOR', > 'VERSION DU FORMAT DE COORD INCONNU') GOTO 9999 C ---- VERSION 1 ---- 10 CONTINUE IF( IACTIO.EQ.0 )THEN READ(IUNIT,*,ERR=290,END=295) > (COORD(J),J=1,IDIMC) DO 12 J=IDIMC+1,NBNOMX COORD(J)= 0.0 12 CONTINUE C ISOMME EST DONNE EN PARAMETRE ELSE WRITE(IUNIT,*) (COORD(J),J=1,IDIMC) ENDIF GOTO 100 C ---- VERSION 2 ---- 20 CONTINUE IF( IACTIO.EQ.0 )THEN READ(IUNIT,*,ERR=290,END=295) ISOMME, > (COORD(J),J=1,IDIMC) DO 22 J=IDIMC+1,NBNOMX COORD(J)= 0.0 22 CONTINUE ELSE WRITE(IUNIT,*) ISOMME,(COORD(J),J=1,IDIMC) ENDIF GOTO 100 C -------- 100 CONTINUE C ------------------------------ C ---- VERIFICATION POUR LA LECTURE --- C ------------------------------ IF( IACTIO.EQ.1 )GOTO 9999 GOTO 9999 C ----------------------------- C ---- GESTION DES ERREURS DU BLOC ---- C ----------------------------- 290 IERR = -1 CALL ESERRE(1,IERR,'ESCOOR', > ' ERREUR LECTURE SOMMET') PRINT *,'SOMMET = ',ISOMME GOTO 9999 295 IERR = -1 CALL ESERRE(1,IERR,'ESCOOR', > ' SOMMET INCOMPLET') PRINT *,'SOMMET = ',ISOMME GOTO 9999 C 9999 END C C SUBROUTINE ESARET(IACTIO,IUNIT,IVERSI, > IARETE,ITNOAR,NBNOMX,ITFAAR,NBFAAR,NBFAMX, > IERR) C ***************************************************************** C OBJET ESARET : LECTURE/ECRITURE D'UNE ARETE C EN ENTREE : C IACTIO : 0 LECTURE C 1 ECRITURE C IUNIT : -1 STDERR/STDIN (A FAIRE) C 0 STDOUT/STDIN (A FAIRE) C 1..25 FICHIER (RENVOYE PAR GESFIC) C IVERSI : VERSION DU FORMAT C C ***************************************************************** INTEGER IACTIO,IUNIT,IVERSI INTEGER IARETE,ITNOAR(*),NBNOMX,ITFAAR(*),NBFAAR,NBFAMX INTEGER IERR C INTEGER J,K,NBNNOI,NBNFAI,NCODE,IC INTEGER MAXSOM,MAXFAC PARAMETER (MAXSOM = 27, MAXFAC = 10) INTEGER LECSOM(MAXSOM),LECFAC(MAXFAC) C IERR = 0 C ------------------------------ C ---- VERIFICATION POUR L'ECRITURE --- C ------------------------------ IF( IACTIO.EQ.1 )THEN IF((NBNOMX.NE.2).OR.(NBFAAR.GT.4))THEN IERR = -1 CALL ESERRE(1,IERR,'ESARET', > ' UNE ARETE BIZARRE') PRINT *,'ARETE = ',IARETE GOTO 9999 ENDIF ENDIF C ------------------------------ C ---- LECTURE / ECRITURE ---- C ------------------------------ C C LE FORMAT LIBRE POSE DES PROBLEMES CAR SUR L'O2 C LA LIGNE NE CONTIENT ALORS QUE 73 CARACTERES... C C IF( IVERSI )GOTO (10,20) IVERSI GOTO (10,20) IVERSI C ---- VERSION INCONNUE ---- IERR = -1 CALL ESERRE(1,IERR,'ESARET', > 'VERSION DU FORMAT D ARETE INCONNU') GOTO 9999 C ---- VERSION 1 ---- 10 CONTINUE IF( IACTIO.EQ.0 )THEN READ(IUNIT,*,ERR=290,END=295) > NBNNOI,(LECSOM(J),J=1,MIN(NBNNOI,MAXSOM)),IC, > NBNFAI,(LECFAC(J),J=1,MIN(NBNFAI,MAXFAC)) C IARETE EST DONNE EN PARAMETRE ELSE NCODE = 100 WRITE(UNIT=IUNIT,FMT='(11I10)') > NBNOMX,(ITNOAR(K),K=1,NBNOMX), > NCODE, > NBFAAR, (ITFAAR(K),K=1,NBFAAR) ENDIF GOTO 100 C ---- VERSION 2 ---- 20 CONTINUE IF( IACTIO.EQ.0 )THEN READ(IUNIT,*,ERR=290,END=295) IARETE, > NBNNOI,(LECSOM(J),J=1,MIN(NBNNOI,MAXSOM)), > NBNFAI,(LECFAC(J),J=1,MIN(NBNFAI,MAXFAC)) IC = 100 ELSE WRITE(UNIT=IUNIT,FMT='(11I10)') IARETE, > NBNOMX,(ITNOAR(K),K=1,NBNOMX), > NBFAAR, (ITFAAR(K),K=1,NBFAAR) ENDIF GOTO 100 C -------- 100 CONTINUE C ------------------------------ C ---- VERIFICATION POUR LA LECTURE --- C ------------------------------ IF( IACTIO.EQ.1 )GOTO 9999 IF((NBNNOI.GT.NBNOMX).OR.(NBNNOI.GT.MAXSOM))THEN IERR = -2 CALL ESERRE(1,IERR,'ESARET', > ' UNE ARETE A TROP DE NOEUDS') PRINT *,'ARETE = ',IARETE GOTO 9999 ENDIF DO 260 J=1,NBNNOI ITNOAR(J)=LECSOM(J) 260 CONTINUE DO 261 J=NBNNOI+1,NBNOMX ITNOAR(J)=0 261 CONTINUE C IF((NBNFAI.GT.NBFAMX).OR.(NBNFAI.GT.MAXFAC))THEN IERR = -2 CALL ESERRE(1,IERR,'ESARET', > 'BLOC DEBARE, UNE ARETE A TROP DE FACES') PRINT *,'ARETE = ',IARETE GOTO 9999 ENDIF NBFAAR = NBNFAI DO 270 J=1,NBNFAI ITFAAR(J)=LECFAC(J) 270 CONTINUE DO 271 J=NBNFAI+1,NBFAMX ITFAAR(J) = 0 271 CONTINUE GOTO 9999 C ----------------------------- C ---- GESTION DES ERREURS DU BLOC ---- C ----------------------------- 290 IERR = -1 CALL ESERRE(1,IERR,'ESARET', > 'BLOC DEBARE, ERREUR LECTURE ARETE') PRINT *,'ARETE = ',IARETE GOTO 9999 295 IERR = -1 CALL ESERRE(1,IERR,'ESARET', > 'BLOC DEBARE, ARETE INCOMPLETE') PRINT *,'ARETE = ',IARETE GOTO 9999 C 9999 END C C C SUBROUTINE ECRBRP(NOM,IVERSIO, > ISOMME,COORD,IDIMC,NBN, > IARETE,NBARET,ITNOAR,NBNOMX, > ITFAAR,NBFAAR,NBFAMX, > IFACES,NBFACE,ITVOFA,NBVOFA,NBVOMX, > IERR) C ***************************************************************** C OBJET ECRBRP : ECRITURE D'UNE FRONTIERE (BREP) C UNE ARETE EST DECRITE PAR SES SOMMETS ET LA LISTE DES FACES C INCIDENTES : N1 N2 NBFACES F1 F2 ... FN C C IDEM DS1 MAIS TRIMAT N'EST PLUS LES INTERVALS : C C'EST DIRECTEMENT LES REFERENCES DES ELEMENTS ! C EN ENTREE : C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C C ISOMME() : TABLEAU INDICES DES SOMMETS C COORD,IDIMC,NBN : TABLEAU DES COORDONNEES DES POINTS C --- LES ARETES DE LA FRONTIERES --- C IARETE(),NBARET : TABLEAU INDICES DES ARETES C ITNOAR(),NBNOMX : TABLEAU DES NOEUDS DES ARETES C ITFAAR(),NBFAAR(),NBFMAX : TABLEAU DES FACES INCIDENTES AUX ARETES C --- LES FACES DE LA FRONTIERE --- C IFACES(),NBFACE : TABLEAU DES FACES C ITVOFA(),NBVOFA(),NBVOMX : TABLEAU DES VOLUMES INCIDENTS AUX FACES C C EN SORTIE : C IERR=0 : PAS D'ERREUR C IERR=-1 : PROBLEME D'OUVERTURE DU FICHIER C IERR=-2 : L'UN DES TABLEAUX EST TROP PETIT C C ***************************************************************** CHARACTER*(*) NOM INTEGER IVERSIO INTEGER ISOMME(*) REAL COORD(*) INTEGER IDIMC,NBN INTEGER IARETE(*),NBARET,ITNOAR(*),NBNOMX INTEGER ITFAAR(*),NBFAAR(*),NBFAMX INTEGER IFACES(*),ITVOFA(*),NBVOFA(*),NBVOMX,NBFACE INTEGER IERR C INTEGER IUNIT,I,J,K INTEGER NBNE,NCODE,NMAT,IMATD,IMATF INTEGER NBVERS PARAMETER (NBVERS=3) INTEGER IVERS(NBVERS) INTEGER IACTIO C IACTIO = 1 GOTO (10,20) IVERSIO IERR = -1 CALL ESERRE(1,IERR,'ECRBRP',' ATTENTION VERSION INCONNUE') GOTO 9999 10 CONTINUE IVERS(1)= 1 IVERS(2)= 1 IVERS(3)= 1 GOTO 100 20 CONTINUE IVERS(1)= 2 IVERS(2)= 2 IVERS(3)= 2 GOTO 100 100 CONTINUE C CALL GESFIC('O',NOM,0,0,IUNIT,IERR) IF(IERR.NE.0)THEN CALL ESERRE(1,IERR,'ECRBRP',' ATTENTION LE FICHIER EXISTE DEJA') GOTO 9999 ENDIF C WRITE(IUNIT,'(A)') '* FRT 1.0 FICHIER FRONTIERE (BREP)' C C -------------------------------------- C I. ECRITURE DES COORDONNEES DES NOEUDS C -------------------------------------- WRITE(IUNIT,'(A)')'DEBXYZ' C WRITE(IUNIT,'(A)')'* DEBXYZ 1.0' WRITE(IUNIT,*) NBN, IDIMC DO 110 I=1,NBN CALL ESCOOR(IACTIO,IUNIT,IVERS(1), > ISOMME(I),COORD((I-1)*IDIMC+1),NBNOMX,IDIMC, > IERR) IF( IERR.NE.0 )GOTO 999 110 CONTINUE WRITE( IUNIT,'(A)')'FINXYZ' C C ------------------------ C I. ECRITURE DES ARETES C ------------------------ IF( NBARET .EQ. 0 )GOTO 100 GOTO (120,130) IVERS(2) GOTO 999 C --- POUR ETRE COMPRIS DE DSGG --- 120 WRITE(IUNIT,'(A)')'DEBARE' WRITE(IUNIT,*) NBARET, NBNOMX, NBFAMX C WRITE(IUNIT,*) NBARET GOTO 190 130 WRITE(IUNIT,'(A)')'DEBARE' WRITE(IUNIT,*) NBARET, NBNOMX, NBFAMX GOTO 190 190 CONTINUE C NCODE = 100 DO 200 J=1,NBARET CALL ESARET(IACTIO,IUNIT,IVERS(2), > IARETE(J),ITNOAR((J-1)*NBNOMX+1),NBNOMX, > ITFAAR((J-1)*NBFAMX+1),NBFAAR(J),NBFAMX, > IERR) IF(IERR.NE.0)GOTO 999 200 CONTINUE GOTO (220,230) IVERS(2) GOTO 999 220 WRITE( IUNIT,'(A)')'FINARE' GOTO 290 230 WRITE( IUNIT,'(A)')'FINARE' GOTO 290 290 CONTINUE C C III. ECRITURE DES FACES C ------------------------ IF( NBFACE .EQ. 0 )GOTO 100 WRITE(IUNIT,'(A)')'DEBFAC' C WRITE(IUNIT,'(A)')'* DEBFAC 1.0' WRITE(IUNIT,*) NBFACE, NBVOMX C DO 300 J=1,NBFACE CALL ESFACE(IACTIO,IUNIT,IVERS(3), > IFACES(J),ITVOFA((J-1)*NBVOMX+1),NBVOFA(J),NBVOMX, > IERR) C WRITE(IUNIT,*) IFACES(J),NBVOFA(J), C > (ITVOFA((J-1)*NBVOMX+K),K=1,NBVOFA(J)) 300 CONTINUE C WRITE(IUNIT,'(A)')'FINFAC' C 999 CALL GESFIC('F',NOM,0,0,IUNIT,IERR) 9999 CONTINUE END C C C SUBROUTINE BLCFAC(IACTIO,IUNIT,IVERSI, c > IFACES,NBFACE,ITVOFA,NBVOFA,NBVOMX,IERR) > IFACES,NBFACE,ITVOFA,NBVOFA,NBFAMX,NBVOMX,IERR) C ***************************************************************** C OBJET BLCFAC : LECTURE/ECRITURE DU BLOC DES FACES C EN ENTREE : C NOM : DU FICHIER C NBVOFA : TABLEAU DES "VOLUMES" DES FACES C NBFAMX : NBRE DE COLONNES DE NBVOFA C EN SORTIE : C NBVOMX : EN ECRITURE !!! C = NBFAMX LECTURE SEULEMENT,TAILLE ITVOFA(NBFAMX*NBFACE) C ***************************************************************** INTEGER IACTIO,IUNIT,IVERSI INTEGER IFACES(*),NBFACE,ITVOFA(*),NBVOFA(*),NBFAMX,NBVOMX,IERR C INTEGER I,J,IT,NBLC C IF( IACTIO.EQ.0 )THEN C ------------------------ C 1. LECTURE DES FACES C ------------------------ CALL GESFIC('O',' ',2,0,IT,IERR) CALL GESCOM(IUNIT,'DEBFAC',6,'FINFAC',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)THEN IERR = -1 CALL ESERRE(1,IERR,'BLCFAC','BLOC DEBFAC, PAS TROUVE') GOTO 999 ENDIF REWIND IT READ(IT,*,ERR=390,END=395) NBFACE,NBVOMX C C READ(IT,*,ERR=390,END=395) NBFAL,NBVOL C NBFAL = MIN(NBFAL,NBFACE) C DO 100 I=1,NBFAL C DO 100 I=1,NBFACE CALL ESFACE(IACTIO,IT,IVERSI, C > IFACES(I),ITVOFA((I-1)*NBVOMX+1),NBVOFA(I),NBVOMX, > IFACES(I),ITVOFA((I-1)*NBFAMX+1),NBVOFA(I),NBFAMX, > IERR) IF(IERR.NE.0)GOTO 999 100 CONTINUE ELSE C ------------------------ C 2. ECRITURE DES FACES C ------------------------ IF( NBFACE .EQ. 0 )GOTO 9999 WRITE(IUNIT,'(A)')'DEBFAC' WRITE(IUNIT,*) NBFACE, NBVOMX DO 300 J=1,NBFACE CALL ESFACE(IACTIO,IUNIT,IVERSI, > IFACES(J),ITVOFA((J-1)*NBVOMX+1),NBVOFA(J),NBVOMX, > IERR) 300 CONTINUE WRITE(IUNIT,'(A)')'FINFAC' ENDIF GOTO 999 C ----------------------------- C ---- GESTION DES ERREURS DES BLOCS ---- C ----------------------------- 390 IERR = -1 CALL ESERRE(1,IERR,'BLCFAC', > 'BLOC, ERREUR LECTURE ENTETE') GOTO 999 395 IERR = -1 CALL ESERRE(1,IERR,'BLCFAC', > 'BLOC, ENTETE INCOMPLET') GOTO 999 C --- FIN --- 999 CALL GESFIC('F',' ',0,0,IT,I) C 9999 END C C SUBROUTINE LICBRP(NOM,IVERSIO, > BLCXYZ,IVXYZ,IDIMC,NBN, > BLCARE,IVARE,NBARET,NBNOMX,NBFAMX, > BLCFAC,IVFAC,NBFACE,NBVOMX, > IERR) C ***************************************************************** C OBJET LICBRP : LECTURE DES ENTETES D'UN FICHIER BREP (FRONTIERE) C EN ENTREE : C NOM : DU FICHIER C EN SORTIE : LES BLOCS ET LEURS CARDINAUX C ***************************************************************** CHARACTER*(*) NOM INTEGER IVERSIO INTEGER BLCXYZ,IVXYZ,IDIMC,NBN INTEGER BLCARE,IVARE,NBARET,NBNOMX,NBFAMX INTEGER BLCFAC,IVFAC,NBFACE,NBVOMX INTEGER IERR C INTEGER INTMAX PARAMETER (INTMAX = 3) INTEGER INENTE(INTMAX) INTEGER NBLXYZ,NBLARE,NBLFAC C INTEGER BLCXYZ,BLCARE,BLCFAC C ====================================== CALL LICBLC(NOM,'XYZ','DEBXYZ','FINXYZ',2,'*', > BLCXYZ,IVXYZ,INENTE,NBLXYZ,IERR) IF( IERR.NE. 0 )GOTO 9999 IF( BLCXYZ.EQ. -1 )GOTO 9999 IF( BLCXYZ.EQ.1 )THEN NBN = INENTE(1) IDIMC = INENTE(2) ENDIF C ====================================== CALL LICBLC(NOM,'ARE','DEBARE','FINARE',3,'*', > BLCARE,IVARE,INENTE,NBLARE,IERR) IF( IERR.NE. 0 )GOTO 9999 IF( BLCARE.EQ. -1 )GOTO 9999 IF( BLCARE.EQ.1 )THEN NBARET = INENTE(1) NBNOMX = INENTE(2) NBFAMX = INENTE(3) ENDIF C ====================================== CALL LICBLC(NOM,'FAC','DEBFAC','FINFAC',2,'*', > BLCFAC,IVFAC,INENTE,NBLFAC,IERR) IF( IERR.NE. 0 )GOTO 9999 IF( BLCFAC.EQ. -1 )GOTO 9999 IF( BLCFAC.EQ.1 )THEN NBFACE = INENTE(1) NBVOMX = INENTE(2) ENDIF C ====================================== C VERIFIER LA COHERENCE ET LA SEMANTIQUE DES 3 BLOCS ! C IF(BLCXYZ.EQ.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'PAS DE BLOC DEBXYZ ?!!') GOTO 9999 ENDIF IF(NBN.LE.0)THEN C ---> IL FAUT AU MOINS UN POINT ! IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'BLOC DEBXYZ, PAS DE POINT, ?!!') GOTO 9999 ENDIF IF(IDIMC.LE.0)THEN C ---> IL FAUT AU MOINS UN POINT ! IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'BLOC DEBXYZ, DIM INCORECTE ?!!') GOTO 9999 ENDIF C IF(NBLXYZ.NE.NBN)THEN C ---> IL FAUT NBN COORDONNEES : LIGNES !!! C IERR = 0 C CALL ESERRE(1,IERR,'LICBRP', C > 'BLOC DEBXYZ, ATTENTION NBRE DE COORD != NBRE LIGNES !!') C PRINT *,'NBN = ',NBN,' NBLXYZ = ',NBLXYZ C ENDIF C ========================================= IF(BLCARE.EQ.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'PAS DE BLOC DEBARE ?!!') GOTO 9999 ENDIF IF(NBARET.LE.0)THEN C ---> IL FAUT AU MOINS UNE ARETE ! IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'BLOC DEBILM, IL N Y A PAS D ARETE!!') GOTO 9999 ENDIF C IF(NBLARE.NE.NBARET)THEN C ---> IL FAUT NBN COORDONNEES : LIGNES !!! C IERR = 0 C CALL ESERRE(1,IERR,'LICBRP', C > 'BLOC DEBARE, ATTENTION NBRE D ARETES != NBRE LIGNES !!') C PRINT *,'NBN = ',NBARET,' NBLARE = ',NBLARE C ENDIF C ========================================= IF(BLCFAC.EQ.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'PAS DE BLOC DEBFAC ?!!') GOTO 9999 ENDIF IF(NBFACE.LE.0) THEN C ---> IL FAUT AU MOINS UNE FACE ! IERR = -1 CALL ESERRE(1,IERR,'LICBRP', > 'BLOC DEBFAC, IL N Y A PAS DE FACE!!') GOTO 9999 ENDIF C IF(NBLFAC.NE.NBFACE)THEN C ---> IL FAUT NBN COORDONNEES : LIGNES !!! C IERR = 0 C CALL ESERRE(1,IERR,'LICBRP', C > 'BLOC DEBFAC, ATTENTION NBRE DE FACES != NBRE LIGNES !!') C PRINT *,'NBN = ',NBFACE,' NBLFAC = ',NBLFAC C ENDIF C ========================================= 9999 END C C C SUBROUTINE LICBLC(NOM,NOMBLC,DEBBLC,FINBLC,NBENTE,COMMEN, > BLCPRE,IVEBLC,INENTE,NBLC, > IERR) C ***************************************************************** C OBJET LICBLC : LECTURE DE L'ENTETE D'UN BLOC C EN ENTREE : C NOM : DU FICHIER C NOMBLC : NOM DU BLOC (3 CARACTERES) INUTILISE C DEBBLC : CHAINE MARQUANT LE DEBUT DU BLOC C FINBLC : CHAINE MARQUANT LA FIN DU BLOC C NBENTE : NOMBRE D'ENTIER A LIRE DANS L'ENTETE C COMMEN : CARACTERE DE COMMENTAIRE C INENTE : TABLEAU DES (NBENTE) ENTIERS DE L'ENTETE DU BLOC C C EN SORTIE : C BLCPRE : 1 = PRESENCE DU BLOC C 0 = ABSCENCE " " C -1 = ERREUR DANS L'ENTETE DU BLOC C IVEBLC : VERSION DU BLOC C INENTE : ENTIERS DE L'ENTETE DU BLOC C NBLC : NOMBRE DE LIGNES DU BLOC C C A FAIRE LICBLC : LIRE LA VERSION DU BLOC C ***************************************************************** CHARACTER*(*) NOM,NOMBLC,DEBBLC,FINBLC CHARACTER COMMEN INTEGER NBENTE INTEGER BLCPRE,IVEBLC,INENTE(*),NBLC INTEGER IERR C INTEGER I,IT,NB1,NB2,IN,IERR2 INTEGER ESLGCH EXTERNAL ESLGCH C IERR = 0 C ---- A FAIRE : IVEBLC = 1 C CALL GESFIC('O',NOM,1,0,IN,IERR) CALL GESFIC('O',' ',2,0,IT,IERR2) IF(IERR.NE.0.OR.IERR2.NE.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LICBLC', > 'PB OUVERTURE FICHIER') GOTO 9999 ENDIF C ====================================== C CALL GESCOM(IN,'DEBFAC',6,'FINFAC',6,'*',IT,NBLC,IERR) C NB1 = ESLGCH(DEBBLC) NB2 = ESLGCH(FINBLC) C --- ON COPIE LE BLOC (SANS LES COMMENTAIRES) DE IN VERS IT --- REWIND IN REWIND IT CALL GESCOM(IN,DEBBLC,NB1,FINBLC,NB2,COMMEN,IT,NBLC,IERR) REWIND IT IF( IERR .NE. 0 )THEN C --- abscence du bloc IERR = 0 BLCPRE = 0 ELSE BLCPRE = 1 IF(NBENTE.GT.0)THEN READ(IT,*,ERR=190,END=190)(INENTE(I),I=1,NBENTE) ENDIF ENDIF GOTO 999 C 190 CONTINUE BLCPRE = -1 IERR = -1 CALL ESERRE(1,IERR,'LICBLC', > 'ENTETE INCORRECT DANS BLOC') GOTO 999 C ====================================== C --- FIN --- 999 CALL GESFIC('F',' ',0,0,IN,I) CALL GESFIC('F',' ',0,0,IT,I) 9999 END C C C SUBROUTINE LITBRP(NOM,IVERSIO, > IDIMC,NBN,NBARET,NBFACE, > ISOMME,COORD,NBCOMX,NBNMAX, > IARETE,NBARMX,ITNOAR,NBNOMX,ITFAAR,NBFAAR,NBFAMX, > IFACES,NBFMAX,ITVOFA,NBVOFA,NBVOMX, > IERR) C ***************************************************************** C OBJET LITBRP : LECTURE D'UNE BREP (FRONTIERE) C EN ENTREE : C NOM : NOM DU FICHIER A OUVRIR, LIRE PUIS FERMER C IVERSIO: VERSION DU FICHIER A LIRE C EN SORTIE : C IERR=0 : PAS D'ERREUR C IERR=-1 : PROBLEME D'OUVERTURE DU FICHIER, DE FORMAT.... C IERR=-2 : L'UN DES TABLEAUX EST TROP PETIT C ---- LES DIMENSIONS DU MAILLAGE --- C SI ACTION = 0 C IDIMC : DIMENSION DE L'ESPACE (NB MAXI DE COORDONNEES/NOEUD) C NBN : NOMBRE TOTAL DES POINTS (NOEUDS) C IDE : DIMENSION MAXIMALE DE LA TOPOLOGIE DES ELEMENTS C NBNMAX : NOMBRE MAXIMAL DE NOEUDS PAR ELEMENT C NBE : NOMBRE D'ELEMENTS C NBRMAX : NOMBRE MAXIMAL DE REGIONS PAR ELEMENT C ATTENTION : C ON CONSIDERE QUE LE FICHIER ET SES ENTETES SONT CORRECTS ???? C C ***************************************************************** CHARACTER*(*) NOM INTEGER IVERSIO INTEGER IDIMC,NBN,NBARET,NBFACE INTEGER ISOMME(*) REAL COORD(*) INTEGER NBCOMX,NBNMAX INTEGER IARETE(*),NBARMX INTEGER ITNOAR(*),NBNOMX,ITFAAR(*),NBFAAR(*),NBFAMX INTEGER IFACES(*),NBFMAX,ITVOFA(*),NBVOFA(*),NBVOMX INTEGER IERR C INTEGER IN,IT,NBLC,I,J INTEGER IC INTEGER IDIMCL,NBNL INTEGER INDICE,NBAREL,NBNAL INTEGER NBNNOI,NBNFAI,NBVOL,NBFAL,NBNVOL C INTEGER NBVERS PARAMETER (NBVERS=3) INTEGER IVERS(NBVERS) INTEGER IACTIO C IACTIO = 0 GOTO (10,20) IVERSIO IERR = -1 CALL ESERRE(1,IERR,'ECRBRP',' ATTENTION VERSION INCONNUE') GOTO 9999 10 CONTINUE IVERS(1)= 1 IVERS(2)= 1 IVERS(3)= 1 GOTO 100 20 CONTINUE IVERS(1)= 2 IVERS(2)= 2 IVERS(3)= 2 GOTO 100 100 CONTINUE C CALL GESFIC('O',NOM,1,0,IN,IERR) CALL GESFIC('O',' ',2,0,IT,I) IF(IERR.NE.0.OR.I.NE.0) GOTO 80 C ====================================== C --- 1. LECTURE DES COORDONNEES DES POINTS --- C ====================================== REWIND IN REWIND IT CALL GESCOM(IN,'DEBXYZ',6,'FINXYZ',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBXYZ, PAS TROUVE') GOTO 999 ENDIF REWIND IT READ(IT,*,ERR=390,END=395) NBNL,IDIMCL C --- ON PEUT LIRE SEULEMENT QUELQUES POINTS : NBNMAX < NBNL C --- ON PEUT LIRE SEULEMENT QUELQUES COORDONNEES : NBCOMX < IDIMCL C OU CHARGER DANS UN TABLEAU DE DIMENSION SUPERIEURE : IDIMCL < NBCOMX IF(NBN.GT.NBNL)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'NOMBRE DE COORDONNEES INSUFFISANT DS FICHIER !') GOTO 999 ENDIF IF((NBCOMX.LT.IDIMCL).OR.(NBNMAX.LT.NBNL))THEN IERR = 0 CALL ESERRE(1,IERR,'LITBRP', > 'ATTENTION LECTURE PARTIELLE BLOC XYZ !') ENDIF IDIMC = MIN(IDIMC,IDIMCL) NBN = MIN(NBNMAX,NBNL) DO 130 I=1,NBN CALL ESCOOR(IACTIO,IT,IVERS(1), > ISOMME(I),COORD((I-1)*NBCOMX+1),NBCOMX,IDIMC, > IERR) IF(IERR.NE.0)GOTO 999 130 CONTINUE C ====================================== C --- 2. LECTURE DES ARETES --- C ====================================== 200 CONTINUE REWIND IN REWIND IT CALL GESCOM(IN,'DEBARE',6,'FINARE',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBARE, PAS TROUVE') GOTO 999 ENDIF REWIND IT READ(IT,*,ERR=390,END=395) NBAREL,NBNAL,NBFAL C --------------------- C ---- VERIFICATION MEMOIRE ---- C --------------------- IF(NBARET.LT.NBAREL)THEN IERR = 0 CALL ESERRE(1,IERR,'LITBRP', > 'ATTENTION LECTURE PARTIELLE BLOC ARE !') ENDIF IF(NBARET.GT.NBARMX)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBARE, IL Y TROP D ARETE') GOTO 999 ENDIF IF(NBNAL.GT.NBNOMX)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBARE, IL N Y TROP DE SOMMET PAR ARETE') GOTO 999 ENDIF IF(NBFAL.GT.NBFAMX)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBARE, IL N Y TROP DE FACES PAR ARETE') GOTO 999 ENDIF C --------------------- C ---- LECTURE ELEMENTS ---- C --------------------- DO 280 I=1,NBARET CALL ESARET(IACTIO,IT,IVERS(2), > IARETE(I),ITNOAR((I-1)*NBNOMX+1),NBNOMX, > ITFAAR((I-1)*NBFAMX+1),NBFAAR(I),NBFAMX, > IERR) IF(IERR.NE.0)GOTO 999 280 CONTINUE C C ====================================== C --- 3. LECTURE DES FACES --- C ====================================== C 300 CONTINUE C --------------------- C ---- LECTURE ENTETE ---- C --------------------- REWIND IN REWIND IT CALL GESCOM(IN,'DEBFAC',6,'FINFAC',6,'*',IT,NBLC,IERR) IF(IERR.NE.0)THEN IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBFAC, PAS TROUVE') GOTO 999 ENDIF REWIND IT READ(IT,*,ERR=390,END=395) NBFAL,NBVOL C --------------------- C ---- VERIFICATION MEMOIRE ---- C --------------------- IF(NBFAL.GT.NBFMAX)THEN IERR = -2 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBILM, IL N Y TROP DE FACES') GOTO 999 ENDIF IF(NBVOL.GT.NBVOMX)THEN IERR = -2 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC DEBILM, IL N Y TROP DE VOLUMES PAR FACE') GOTO 999 ENDIF IF(NBFAL.GT.NBFACE)THEN IERR = 0 CALL ESERRE(1,IERR,'LITBRP', > 'ATTENTION LECTURE PARTIELLE BLOC FAC !') ENDIF C --------------------- C ---- LECTURE ELEMENTS ---- C --------------------- NBFAL = MIN(NBFAL,NBFACE) DO 380 I=1,NBFAL CALL ESFACE(IACTIO,IT,IVERS(3), > IFACES(I),ITVOFA((I-1)*NBVOMX+1),NBVOFA(I),NBVOMX, > IERR) IF(IERR.NE.0)GOTO 999 380 CONTINUE GOTO 999 C ----------------------------- C ---- GESTION DES ERREURS DES BLOCS ---- C ----------------------------- 390 IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC, ERREUR LECTURE ENTETE') GOTO 999 395 IERR = -1 CALL ESERRE(1,IERR,'LITBRP', > 'BLOC, ENTETE INCOMPLET') GOTO 999 C -------------------------------------------------------- 900 CONTINUE GOTO 999 C --- TRAITEMENT DES ERREURS --- 80 CONTINUE IERR=-1 GOTO 999 90 CONTINUE IERR=-2 GOTO 999 C --- FIN --- 999 CALL GESFIC('F',' ',0,0,IN,I) CALL GESFIC('F',' ',0,0,IT,I) 9999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_PROG.F C OBJET : GERENT LES ES DES PROGRAMMES PRINCIPAUX C FONCT. : C C OBJET ESVNOM : VERIFIE QUE LA CHAINE EST UN NOM C OBJET ESAMOT : ANALYSE UN MOT C OBJET ESGARG : LIT LES ARGUMENTS DES PROGRAMMES -> CHAINE C OBJET ESGARG : LIT LES ENTREES DE L'UTILISATEUR -> CHAINE C OBJET ESCONV : CONVERTI UNE CHAINE EN ENTIER, REELS... C OBJET ESFORM : FIXE LE FORMAT D'UN ARGUMENT D'UN PROGRAMME C OBJET ESPMOD : DETERMINE LE MODE D'UN PROGRAMME C OBJET ESEPRG : AFFICHE LES INFORMATIONS D'UN PROGRAMME C OBJET ESAARG : ANALYSE LES ARGUMENTS D'UN PROGRAMME C C LIMITATION ESVNOM : NOM LIMITE A 32 CARACTERES C LIMITATION ESCONV : DESCRIPTION DE FORMAT LIMITE A 16 CARACTERES C LIMITATION ESFORM : DESCRIPTION DE FORMAT LIMITE A 16 CARACTERES C LIMITATION ESPMOD : 256 CARACTERES POUR LE 1ER PARAMETRE (S/V) C LIMITATION ESSPRG : VERSION 5 CARACTERES, DATE 30 CARACTERES C LIMITATION ESPLEX : 16 CARACTERES POUR LA DEFINITION DU FORMAT C LIMITATION ESPROG : 50 ARGUMENTS, CHAINE DE 256 CARACTERES C C REMARQUES : C 2 modes de fonctionnement possible pour un programme : C *le mode ligne de commande: seuls les parametres obligatoires sont demandes C il est donc utile de les repousser a la fin, '-' represente la valeur par C defaut un premier parametre v,s,h,d permet d'acceder a plusieurs types C d'affichage v=verbose, s=silence, h=help (l'aide en ligne), d=debug C *le mode interactif: les questions sont posees a l'utilisateur C pour avoir une valeur par defaut il suffit de faire un "enter", C cela devient un "blanc" : ' ' pour la suite du traitement. C C AUTEUR : O.STAB C DATE : 06.98 C MODIFICATIONS : C AUTEUR, DATE, OBJET : o.stab, 18.10.2001, correction ESVNOM C AUTEUR, DATE, OBJET : o.stab, 28.08.2002, bug ESCONV pour les reels C AUTEUR, DATE, OBJET : o.stab, 28.10.2004, ajout mode debug (2) modif ESPMOD C AUTEUR, DATE, OBJET : o.stab, 05.01.2005, modif ESAMOT (longueur des mots) et C une commande incomplete ne bascule plus sur le dialogue C AUTEUR, DATE, OBJET : o.stab, 14.09.2006, ajout appel ESMESS !! C AUTEUR, DATE, OBJET : o.stab, 21.07.2007, appel IARGC n'est plus declare (pour gfortran) C ***************************************************************** FUNCTION ESVNOM(NOM,LNOM) C ***************************************************************** C OBJET ESVNOM : VERIFIE QUE LA CHAINE EST UN NOM C LIMITATION ESVNOM : NOM LIMITE A 32 CARACTERES C ***************************************************************** INTEGER ESVNOM CHARACTER*(*) NOM INTEGER LNOM C CONSTANTE LNOMAX : LONGUEUR MAXIMUM D'UN NOM- PARAMETER (LNOMAX = 32) INTEGER LNOMAX PARAMETER (LNOMAX = 32) INTEGER I C LNOM = LEN(NOM) DO 10 I=1,LNOM IF(((NOM(I:I).GT.'Z' ).OR.(NOM(I:I).LT.'a')).AND. > ((NOM(I:I).GT.'9' ).OR.(NOM(I:I).LT.'0'))) GOTO 20 10 CONTINUE C ---- c'est un nom ---- ESVNOM = 1 GOTO 9999 20 CONTINUE C ---- ce n'est pas un nom ---- LNOM = I ESVNOM = 0 IF( LNOM.GT.LNOMAX )ESVNOM = -1 9999 END C C SUBROUTINE ESAMOT(MOT,LMOT,MOTS,LMOTS,NBMOTS,ICODE,IRESUL) C ***************************************************************** C OBJET ESAMOT : RENVOI LE CODE CORRESPONDANT A "MOT", -1 SI INCONNU C ***************************************************************** CHARACTER*(*) MOT INTEGER LMOT,NBMOTS CHARACTER*(*) MOTS(NBMOTS) INTEGER LMOTS,ICODE(NBMOTS) INTEGER IRESUL C INTEGER I,J,LMOTC C IRESUL = -1 CALL MAJUSC(LMOT,MOT) DO 10 I=1,NBMOTS LMOTC = 0 DO 5 J=1,LMOTS IF(MOTS(I)(J:J).EQ.' ')GOTO 7 LMOTC = LMOTC+1 5 CONTINUE 7 CONTINUE C PRINT *,'LMOT=',LMOT,', LMOTC(',I,')= ',LMOTC IF( MOT(:LMOT).EQ.MOTS(I)(:LMOTC) )GOTO 20 10 CONTINUE GOTO 9999 20 IRESUL = ICODE(I) 9999 END C C SUBROUTINE ESGARG(CHAINE,PTCHAI,NCARMX, > IARGUM,LARGUM,NARGUM,NARGMX,IERR) C *************************************************************** C OBJET ESGARG : LIT LES ARGUMENTS DES PROGRAMMES -> CHAINE C C EN ENTREE : C NCARMX : NOMBRE MAXIMUM DE CARACTERES (TAILLE DE CHAINE) C NARGMX : NOMBRE MAXIMUM D'ARGUMENTS A LIRE C C EN SORTIE : C CHAINE : LA CHAINE DE CARACTERES CONTENANT LES ENTREES C IARGUM : IARGUM(I) = INDICE DU IEME ARGUMENT DANS CHAINE C LARGUM : LARGUM(I) = LONGUEUR " " " " " C NARGUM : NOMBRE D'ARGUMENTS LUS C IERR : CODE D'ERREUR C -1 SI TROP D'ENTREES NARGLU > NARGMX C -2 SI UNE ENTREE CONTIENT TROP DE CARACTERE > NCARMX C *************************************************************** CHARACTER*(*) CHAINE INTEGER PTCHAI,NCARMX,IARGUM(*),LARGUM(*),NARGUM INTEGER NARGMX, IERR C ------------------------------------------------------------------- INTEGER ESLGCH,I,J,NBALIR C INTEGER*4 NBARG,IARGC INTEGER*4 NBARG C EXTERNAL IARGC,ESLGCH EXTERNAL ESLGCH C CHARACTER*256 MESSAG IERR = 0 C#ifdef GFORTRAN222 NBARG = IARGC() C MODIF 21.07.2008 OS, depuis fortran 2003 : C#ESLE C NBARG = COMMAND_ARGUMENT_COUNT() C#ENDIF NBALIR = NBARG - 1 IF(NARGUM.GT.NARGMX)THEN IERR = -1 CALL ESMESS(IERR,33,1,'TROP DE PARAMETRES',MESSAG) CALL ESEINT(1,MESSAG,NARGMX,1) GOTO 9999 ENDIF J = PTCHAI DO 50 I=1,NBALIR IF( J+32.GT.NCARMX )THEN IERR = -2 CALL ESMESS(IERR,34,1,'TROP DE CARACTERES',MESSAG) CALL ESEINT(1,MESSAG,NCARMX,1) GOTO 9999 ENDIF NARGUM = NARGUM + 1 IARGUM(NARGUM) = J C GETARG DEVRAIT ETRE UN TYPE IO DE ESLCHA(IO,...) CALL GETARG(I+1,CHAINE(J:)) C MODIF 21.07.2008 OS, depuis fortran 2003 : C CALL GET_COMMAND_ARGUMENT(I+1,CHAINE(J:)) LARGUM(NARGUM) = ESLGCH(CHAINE(J:)) C --- ABSENCE DE PARAMETRE EN BATCH : '-' --- IF((LARGUM(NARGUM).EQ.1).AND.(CHAINE(J:J).EQ.'-')) > LARGUM(NARGUM) = 0 J = J + LARGUM(NARGUM) CHAINE(J:J) = ' ' J = J + 1 50 CONTINUE PTCHAI = J 9999 END C C SUBROUTINE ESLARG(MESSAG,CHAINE,PTCHAI,NCARMX, > IARGUM,LARGUM,NARGUM,NARGMX,IERR) C *************************************************************** C OBJET ESGARG : LIT LES ENTREES DE L'UTILISATEUR -> CHAINE C C EN ENTREE : C NCARMX : NOMBRE MAXIMUM DE CARACTERES (TAILLE DE CHAINE) C NARGMX : NOMBRE MAXIMUM D'ARGUMENTS A LIRE C C EN SORTIE : C CHAINE : LA CHAINE DE CARACTERES CONTENANT LES ENTREES C IARGUM : IARGUM(I) = INDICE DU IEME ARGUMENT DANS CHAINE C LARGUM : LARGUM(I) = LONGUEUR " " " " " C NARGUM : NOMBRE D'ARGUMENTS LUS C IERR : CODE D'ERREUR -1 SI TROP D'ENTREES NARGLU > NARGMX C *************************************************************** CHARACTER*(*) MESSAG(*),CHAINE INTEGER PTCHAI,NCARMX,IARGUM(*),LARGUM(*),NARGUM INTEGER NARGMX, IERR C ------------------------------------------------------------------- INTEGER ESLGCH,I,J,NBALIR EXTERNAL ESLGCH C IERR = 0 J = PTCHAI NBALIR = NARGMX-NARGUM DO 50 I=1,NBALIR IF( J+32.GT.NCARMX )THEN IERR = -2 CALL ESMESS(IERR,34,1,'TROP DE CARACTERES',MESSAG) CALL ESEINT(1,MESSAG,NCARMX,1) GOTO 9999 ENDIF NARGUM = NARGUM+1 IARGUM(NARGUM) = J CALL ESLCHA(1,MESSAG(NARGUM),CHAINE(J:)) LARGUM(NARGUM) = ESLGCH(CHAINE(J:)) J = J + LARGUM(NARGUM) CHAINE(J:J) = ' ' J = J + 1 50 CONTINUE PTCHAI = J C 9999 END C C SUBROUTINE ESCONV(REP,LREP,ITYPE,IFORMA, > CHARTB,NBCHAR,INTETB,NBINTE,REALTB,NBREAL, > IARGUM,PRESEN,IERR) C *************************************************************** C OBJET ESCONV : CONVERTI UNE CHAINE EN ENTIER, REELS... C C EN ENTREE : C REP : LA CHAINE EN ENTREE C ITYPE : ITYPE(I) = TYPE DU IEME ARGUMENT C 1 CHAINE DE CARACTERE, 2 ENTIER, 3 REEL C IFORMA : IFORMAT(I) = FORMAT DU IEME ARGUMENT C PAR EXEMPLE 'I10' OU '*' POUR UN ENTIER... C ATTENTION LIMITE A 16 CARACTERES C NARGMX : NOMBRE MAXIMUM D'ARGUMENTS A LIRE C C EN SORTIE : C NBCHAR : NOMBRE DE CHAINE DANS CHARTB C NBINTE : NOMBRE D'ENTIERS DANS INTETB C NBREAL : NOMBRE DE REELS DANS REALTB C IARGUM : IARGUM(I) = ADRESSE DU IEME ARGUMENT DANS LE TABLEAU CORRESPONDANT C NARGLU : NOMBRE D'ARGUMENT LU C IERR : CODE D'ERREUR -1 SI LE NOMBRE OU LE FORMAT DES C ENTREES EST INCORRECT. C LIMITATION ESCONV : DESCRIPTION DE FORMAT LIMITE A 16 CARACTERES C *************************************************************** CHARACTER*(*) REP INTEGER LREP,ITYPE CHARACTER*16 IFORMA INTEGER INTETB(*),NBINTE,NBREAL,NBCHAR REAL REALTB(*) CHARACTER*(*) CHARTB(*) INTEGER PRESEN,IARGUM,IERR C ------------------------------------------------------------------- CHARACTER*(1) CHVIDE,CHFIN INTEGER ENTDEF,NBC REAL REEDEF PARAMETER (CHFIN = ' ',CHVIDE = ' ') PARAMETER (ENTDEF = 0, REEDEF = 0.0) INTEGER IOS C IERR = 0 C IF( LREP.LE.0 )THEN C IARGUM = -1 C GOTO 9999 C ENDIF C A FAIRE : AVANT DE FAIRE LE READ ON PEUT VERIFIER LES REELS ET LES ENTIERS GOTO (10,20,30) ITYPE IERR = -1 GOTO 9999 C --- UNE CHAINE -- 10 CONTINUE NBCHAR = NBCHAR+1 IARGUM = NBCHAR C READ (REP(:LREP),FMT = IFORMA,IOSTAT = IOS,ERR=100,END=100) IF( LREP.LE.0 )THEN CHARTB(NBCHAR) = CHVIDE PRESEN = -1 ELSE C READ (UNIT=REP(:LREP),FMT=IFORMA,IOSTAT=IOS, C > ERR=100,END=100) CHARTB(NBCHAR) C READ (UNIT=REP(:LREP),FMT=IFORMA,IOSTAT=IOS, C > ERR=100,END=100) CHARTB(NBCHAR)(:LREP) C C ICI LA DESTINATION PEUT ETRE PLUS GRANDE QUE LA SOURCE C WARNING SUR IBM PAR EXEMPLE ! IF(LREP.LT.100)WRITE (IFORMA,'(A2,I2,A1)') '(A',LREP,')' IF(LREP.LT.10)WRITE (IFORMA,'(A2,I1,A1)') '(A',LREP,')' READ (UNIT=REP,FMT=IFORMA,IOSTAT=IOS, > ERR=100,END=100) CHARTB(NBCHAR) C CHARTB(NBCHAR)(:LREP+1) = CHFIN PRESEN = 1 ENDIF GOTO 9999 C --- UN ENTIER -- 20 CONTINUE IF(LREP.LT.100)WRITE (IFORMA,'(A2,I2,A1)') '(I',LREP,')' IF(LREP.LT.10)WRITE (IFORMA,'(A2,I1,A1)') '(I',LREP,')' NBINTE = NBINTE+1 IARGUM = NBINTE C READ (REP(:LREP),FMT = IFORMA,IOSTAT = IOS,ERR=100,END=100) IF( LREP.LE.0 )THEN INTETB(NBINTE) = ENTDEF PRESEN = -1 ELSE C READ (UNIT=REP(:LREP),FMT=IFORMA,IOSTAT = IOS, READ (UNIT=REP(:LREP),FMT=IFORMA,IOSTAT = IOS, > ERR=100,END=100) INTETB(NBINTE) PRESEN = 1 ENDIF GOTO 9999 C --- UN REEL -- 30 CONTINUE NBC = LREP + 3 C IF(LREP.LT.100)WRITE (IFORMA,'(A2,I2,A3)') '(F',LREP,'.2)' C IF(LREP.LT.10)WRITE (IFORMA,'(A2,I1,A3)') '(F',LREP,'.2)' C WRITE (IFORMA,'(A1)') '*' NBREAL = NBREAL+1 IARGUM = NBREAL C READ (REP(:LREP),FMT = IFORMA,IOSTAT = IOS,ERR=100,END=100) IF( LREP.LE.0 )THEN C REALTB(NBINTE) = REEDEF .... bug 27.08.2002 REALTB(NBREAL) = REEDEF PRESEN = -1 ELSE C READ (UNIT=REP(:LREP),FMT=IFORMA,IOSTAT = IOS, READ (REP(:LREP),*, C READ (UNIT=REP(:LREP),FMT=IFORMA,IOSTAT = IOS, > ERR=100,END=100) REALTB(NBREAL) PRESEN = 1 ENDIF GOTO 9999 C 100 CONTINUE C --- TOUT EST OK --- IF( IOS.EQ. 0 )GOTO 9999 C --- FIN DE FICHIER --- IF( IOS.LT. 0 )GOTO 9999 C --- IOS > 0 UNE ERREUR --- C PRINT *,'ERREUR ESCONV ?? IOS EST POSITIF = ',IOS CALL ESERRE(1,IERR,'ESCONV','?? IOS EST POSITIF ') C IERR = -1 9999 END SUBROUTINE ESFORM(ITYPEL,ITYPEP,IFORMA,IERR) C *************************************************************** C OBJET ESFORM : FIXE LE FORMAT D'UN ARGUMENT D'UN PROGRAMME C ON A LES TYPES SUIVANT : C 1 FD : LES NOMS DES FICHIERS DE DONNEES (VARIABLES) C 2 FR : LES NOMS DES FICHIERS DE RESULTAT C 3 VR : LES VALEURS NUMERIQUES REELLES (CONSTANTES) C 4 VE : LES VALEURS NUMERIQUES ENTIERES C 5 MC : LES MOTS CLES (TOKEN) C 6 = LE NOM D'UN FICHIER DE RESULTAT (ECRASABLE) C 7 = LE NOM D'UN FICHIER DE RESULTAT (CONCATENATION) C LIMITATION ESFORM : DESCRIPTION DE FORMAT LIMITE A 16 CARACTERES C *************************************************************** INTEGER ITYPEL INTEGER ITYPEP CHARACTER*16 IFORMA INTEGER IERR C IERR = 0 GOTO (10,10,20,30,10,10,10) ITYPEL IERR = -1 GOTO 9999 C --- FICHIER ET MOTCLE --- 10 CONTINUE IFORMA = '(A)' ITYPEP = 1 GOTO 9999 C --- CONSTANTES ENTIERES --- 20 CONTINUE IFORMA = '(I10)' ITYPEP = 2 GOTO 9999 C --- CONSTANTES REELLES --- 30 CONTINUE IFORMA = '(F10.2)' ITYPEP = 3 GOTO 9999 9999 END C SUBROUTINE ESPMOD(ITRACE,IHELP) C *************************************************************** C OBJET ESPMOD : DETERMINE LE MODE D'UN PROGRAMME (S. OU VERBOSE) C LIMITATION ESPMOD : 256 CARACTERES POUR LE 1ER PARAMETRE (S/V) C SORTIE : C ITRACE : mode d'affichage des messages C 0 mode silence FLAG="S" C 1 mode verbose FLAG="V","H" (par defaut) C 2 mode verbose FLAG="D" C C IHELP : affichage de l'aide C 0 mode silence FLAG="S","V","D" (par defaut) C 1 mode silence FLAG="H" C *************************************************************** INTEGER ITRACE,IHELP C CHARACTER*256 REP C INTEGER*4 NBARG,IARGC INTEGER*4 NBARG C EXTERNAL IARGC C IHELP = 0 NBARG = IARGC() C MODIF 21.07.2008 OS, depuis fortran 2003 : C NBARG = COMMAND_ARGUMENT_COUNT() IF( NBARG.LT.1 )THEN ITRACE = 1 GOTO 9999 ENDIF C MODIF 21.07.2008 OS, depuis fortran 2003 : C CALL GET_COMMAND_ARGUMENT(1,REP) CALL GETARG(1,REP) ITRACE = 1 C --- ON POURRAIT FAIRE APPEL A ESAMOT !!! IF((REP(1:1).EQ.'S' ).OR.( REP(1:1).EQ.'s' ))ITRACE = 0 IF((REP(1:1).EQ.'D' ).OR.( REP(1:1).EQ.'d' ))ITRACE = 2 IF((REP(1:1).EQ.'H' ).OR.( REP(1:1).EQ.'h' ))THEN IHELP = 1 GOTO 9999 ENDIF CALL ESINIT(ITRACE) 9999 END C SUBROUTINE ESEPRG(IO,NOMPRG,RELEAS,COPYRI,DATE,CONTAC) C *************************************************************** C OBJET ESEPRG : AFFICHE LES INFORMATIONS D'UN PROGRAMME C LIMITATION ESSPRG : VERSION 5 CARACTERES, DATE 30 CARACTERES C *************************************************************** INTEGER IO CHARACTER*(*) NOMPRG REAL RELEAS CHARACTER*(*) COPYRI INTEGER DATE CHARACTER*(*) CONTAC C CHARACTER*5 VERSIO CHARACTER*30 CDATE INTEGER ANNEE,MOIS,JOUR CHARACTER*256 MESSAG C IF( RELEAS.GT. 0 )THEN WRITE (VERSIO,FMT = '(F5.2)') RELEAS CALL ESECHA(IO,NOMPRG,VERSIO) ELSE CALL ESECHA(IO,NOMPRG,' ') ENDIF C CALL ESEREA(IO,NOMPRG,RELEAS,1) IF( DATE.GT.0 )THEN ANNEE = DATE / 10000 MOIS = ( DATE - ANNEE*10000 ) /100 JOUR = DATE - ANNEE*10000 - MOIS*100 C CALL ESEINT(IO,'DATE :',DATE,1) WRITE (CDATE,FMT ='(I3,I3,I5)')JOUR,MOIS,ANNEE CALL ESMESS(101,8,1,'DATE',MESSAG) CALL ESECHA(IO,MESSAG,CDATE) ENDIF CALL ESMESS(101,9,1,'CONTACT : ',MESSAG) IF( CONTAC(1:1).NE.' ')CALL ESECHA(IO,MESSAG,CONTAC) 9999 END C SUBROUTINE ESPLEX(CHAINE, > IARGUM,LARGUM,NARGUM, > ITYPEL,IOPTIO,MESSAG, > MOTS,LMOTS,NBMOTS,ICODES, > CHARTB,NBCHAR,INTETB,NBINTE,REALTB,NBREAL, > PRESEN,ITRACE,IERR) C *************************************************************** C OBJET ESPLEX : ANALYSE LES ARGUMENTS D'UN PROGRAMME C C RECONNAIT L'ABSENCE D'ARGUMENTS (MET IARGUM A -1) C ANALYSE LES MOTS CLE ET LES REMPLACE PAR LEUR CODE C C EN ENTREE : C ---- DESCRIPTION DE LA SIGNATURE DU PROGRAMME ---- C IOPTIO(I) : L'ENTREE I EST OPTIONNELLE (0) OU NECESSAIRE (1) C ITYPEL(I) : TYPE LOGIQUE DE L'ENTREE I C ON A LES TYPES SUIVANT : C 1 FD : LES NOMS DES FICHIERS DE DONNEES (VARIABLES) C 2 FR : LES NOMS DES FICHIERS DE RESULTAT C 3 VR : LES VALEURS NUMERIQUES REELLES (CONSTANTES) C 4 VE : LES VALEURS NUMERIQUES ENTIERES C 5 MC : LES MOTS CLES (TOKEN) C 6 = LE NOM D'UN FICHIER DE RESULTAT (ECRASABLE) C 7 = LE NOM D'UN FICHIER DE RESULTAT (CONCATENATION) C MESSAG(I) : MESSAGE DECRIVANT L'ENTREE I C SERT A L'INVITATION ET AU MESSAGE D'ERREUR C C ---- DICTIONNAIRE POUR LA RECONNAISSANCE DES MOTCLES ---- C LMOTS : NOMBRE DE CARACTERE DU MOTCLE I C NBMOTS: NOMBRE DE MOTCLE C MOTS(I) : CHAINE CORRESPONDANT AU MOTCLE I C ICODE(I) : CODE CORRESPONDANT AU MOTCLE I C C EN SORTIE : C IARGNUM(I) : C C LIMITATION ESPLEX : 16 CARACTERES POUR LA DEFINITION DU FORMAT C REMARQUE : COMMENT MODIFIER LE PROGRAMME POUR UN ANALYSE EN LIGNE ? C *************************************************************** CHARACTER*(*) CHAINE INTEGER IARGUM(*),LARGUM(*),NARGUM INTEGER ITYPEL(*),IOPTIO(*) CHARACTER*(*) MESSAG(*) CHARACTER*(*) MOTS(*) INTEGER NBMOTS,LMOTS,ICODES(*) INTEGER NBCHAR,NBINTE,NBREAL CHARACTER*(*) CHARTB(*) INTEGER INTETB(*) REAL REALTB(*) INTEGER PRESEN(*),ITRACE,IERR C INTEGER ITYPEP,I,J CHARACTER*16 IFORMA CHARACTER*256 MESSA2 C IERR = 0 NBCHAR = 0 NBINTE = 0 NBREAL = 0 C IF(NARGUM.GT.NARGMX)THEN C IERR = -2 C CALL ESERRE(1,IERR,'ESPLEX','TROP DE PARAMETRES') C GOTO 9999 C ENDIF DO 10 I=1,NARGUM C --- C'EST DEJA FAIT DANS ESCONV C IF( LARGUM(I) .LE. 0 )THEN C IARGUM(I) = -1 C GOTO 10 C ENDIF C CALL ESFORM(ITYPEL(I),ITYPEP,IFORMA,IERR) IF( IERR.NE. 0 )THEN CALL ESERRE(1,IERR,'ESPLEX','APPEL ESFORM') GOTO 9999 ENDIF J = IARGUM(I) IF( ITYPEL(I).NE.5 )THEN C --- ANALYSE D'UNE CONSTANTE OU VARIABLE --- CALL ESCONV(CHAINE(J:),LARGUM(I),ITYPEP,IFORMA, > CHARTB,NBCHAR,INTETB,NBINTE,REALTB,NBREAL, > IARGUM(I),PRESEN(I),IERR) C PRINT *,' CHARTB(',I,') = ',CHARTB(I) IF( IERR.NE. 0 )THEN CALL ESERRE(1,IERR,'ESPLEX','APPEL ESCONV') GOTO 9999 ENDIF ELSE C --- ANALYSE D'UN MOT CLE (TOKEN) --- NBINTE = NBINTE+1 CALL ESAMOT(CHAINE(J:),LARGUM(I),MOTS,LMOTS,NBMOTS,ICODES, > INTETB(NBINTE)) IARGUM(I) = NBINTE IF( INTETB(NBINTE).EQ.-1)THEN PRESEN(I) = -1 ELSE PRESEN(I) = 1 ENDIF ENDIF 10 CONTINUE C --- VERIFICATION DES PARAMETRES OPTIONNELS --- DO 20 I=1,NARGUM IF((IOPTIO(I).EQ.1 ).AND.(PRESEN(I).EQ.-1))THEN IERR = -1 CALL ESMESS(IERR,35,1,'PARAMETRE MANQUANT',MESSA2) CALL ESECHA(1,MESSA2,MESSAG(I)) GOTO 9999 ENDIF 20 CONTINUE C 9999 END C SUBROUTINE ESPEXF(NOMVAR,ITYPEL,MESSAG,ITRACE,IERR) C *************************************************************** C OBJET ESPEXF : VERIFIE L'EXISTANCE D'UN OBJET (FICHIER) C (LA DECLARATION D'UNE VARIABLE) C EN ENTREE : C ITYPEL(I) : TYPE LOGIQUE DE L'ENTREE I C 1 = LE NOM D'UN FICHIER DE DONNEES C 2 = LE NOM D'UN FICHIER DE RESULTAT (NON ECRASABLE) C 3 = UNE VALEUR ENTIERE C 4 = UNE VALEUR REELLE C 5 = UN MOT CLES C 6 = LE NOM D'UN FICHIER DE RESULTAT (ECRASABLE) C 7 = LE NOM D'UN FICHIER DE RESULTAT (CONCATENATION) C C EN SORTIE : C REMARQUE : CETTE FONCTION POURRAIT TESTER L'EXISTANCE D'UN C OBJET DANS UNE BASE DE DONNEE... C ITYPEL=6 : pas de test le fichier peut exister ou non ! C *************************************************************** CHARACTER*(*) NOMVAR INTEGER ITYPEL CHARACTER*(*) MESSAG INTEGER ITRACE,IERR C -------------- POUR LA GESTION DE FICHIER ------------------------- INTEGER NEW,IOLDFI,NEWECR,IFORFI,IUNFFI PARAMETER (NEW =0,IOLDFI=1,NEWECR=3,IFORFI=0,IUNFFI=1) INTEGER FITEST EXTERNAL FITEST CHARACTER*256 MESSA2 C ------------------------------------------------------------------- IERR = 0 GOTO (100,200,500,500,500,500,100) ITYPEL IERR = -1 CALL ESERRE(1,IERR,' ','TYPE D ENTREE INCONNU') GOTO 9999 C ------------------ C ---- FICHIER DE DONNEES --- C ------------------ 100 CONTINUE IF( FITEST(NOMVAR,IOLDFI,IFORFI).NE.0 )THEN IERR = -1 CALL ESMESS(IERR,24,1,'IMPOSSIBLE D OUVRIR FICH',MESSA2) CALL ESECHA(1,MESSA2,NOMVAR) GOTO 9999 ENDIF GOTO 500 C ------------------ C ---- FICHIER DE RESULTAT --- C ------------------ 200 CONTINUE IF( FITEST(NOMVAR,NEW,IFORFI).NE.0 )THEN IERR = -1 CALL ESMESS(IERR,23,1,' LE FICHIER EXISTE DEJA',MESSA2) CALL ESECHA(1,MESSA2,NOMVAR) GOTO 9999 ENDIF GOTO 500 500 CONTINUE 9999 END C C SUBROUTINE ESPROG(ITYPEL,IOPTIO,MESSAG, > MOTS,LMOTS,NBMOTS,ICODES, > CHARTB,NBCHAR,INTETB,NBINTE,REALTB,NBREAL, > IARGUM,NARGAL,PRESEN,ITRACE,IERR) C *************************************************************** C OBJET ESPROG : ANALYSE LES ARGUMENTS D'UN PROGRAMME C C RECONNAIT L'ABSENCE D'ARGUMENTS (MET IARGUM A -1) C ANALYSE LES MOTS CLE ET LES REMPLACE PAR LEUR CODE C C EN ENTREE : C ---- DESCRIPTION DE LA SIGNATURE DU PROGRAMME ---- C ITYPEL(I) : TYPE LOGIQUE DE L'ENTREE I C ON A LES TYPES SUIVANT : C 1 FD : LES NOMS DES FICHIERS DE DONNEES (VARIABLES) C 2 FR : LES NOMS DES FICHIERS DE RESULTAT C 3 VR : LES VALEURS NUMERIQUES REELLES (CONSTANTES) C 4 VE : LES VALEURS NUMERIQUES ENTIERES C 5 MC : LES MOTS CLES (TOKEN) C 6 : LE NOM D'UN FICHIER DE RESULTAT (ECRASABLE) C 7 : LE NOM D'UN FICHIER DE RESULTAT (CONCATENATION) C IOPTIO(I) : L'ENTREE I EST OPTIONNELLE (0) OU NECESSAIRE (1) C MESSAG(I) : MESSAGE DECRIVANT L'ENTREE I C SERT A L'INVITATION ET AU MESSAGE D'ERREUR C C ---- DICTIONNAIRE POUR LA RECONNAISSANCE DES MOTCLES ---- C LMOTS : NOMBRE DE CARACTERE DU MOTCLE I C NBMOTS: NOMBRE DE MOTCLE C MOTS(I) : CHAINE CORRESPONDANT AU MOTCLE I C ICODE(I) : CODE CORRESPONDANT AU MOTCLE I C C EN SORTIE : les arguments sont ranges dans un tableau correspondant C a leur type C IARGUM(I) donne l'indice de l'argument I dans le tableau ad hoc C CHARTB,NBCHAR : tableau des mots lus et nombre C INTETB,NBINTE : tableau des entiers lus et nombre C REALTB,NBREAL : tableau des reels lus et nombre C PRESEN(I): 1 si l'argument I est present, -1 sinon C C LIMITATION ESPROG : 50 ARGUMENTS, CHAINE DE 256 CARACTERES C C REMARQUE : COMMENT MODIFIER LE PROGRAMME POUR UN ANALYSE EN LIGNE ? C *************************************************************** INTEGER ITYPEL(*),IOPTIO(*) CHARACTER*(*) MESSAG(*) CHARACTER*(*) MOTS(*) INTEGER NBMOTS,LMOTS,ICODES(*) INTEGER NBCHAR,NBINTE,NBREAL CHARACTER*(*) CHARTB(*) INTEGER INTETB(*) REAL REALTB(*) INTEGER IARGUM(*),NARGAL,PRESEN(*),ITRACE,IERR C --- VARIABLES LOCALES --- INTEGER NARGMX,NCARMX PARAMETER (NARGMX = 50, NCARMX = 256) INTEGER LARGUM(NARGMX),NARGUM,PTCHAI,I CHARACTER*256 CHAINE, MESSA2 C IERR = 0 DO 5 I=1,NARGAL PRESEN(I)=0 5 CONTINUE IF(NARGAL.GT.NARGMX)THEN IERR = -2 CALL ESMESS(IERR,33,1,'TROP DE PARAMETRES',MESSA2) CALL ESEINT(1,MESSA2,NARGAL,1) GOTO 9999 ENDIF C --- LECTURE DES ARGUMENTS DU SHELL --- (GETARG) PTCHAI = 1 NARGUM = 0 C --- remplace les '-' (defaut) par des blancs CALL ESGARG(CHAINE,PTCHAI,NCARMX, > IARGUM,LARGUM,NARGUM,NARGAL,IERR) IF( IERR.NE.0 )GOTO 9999 C PRINT *,'PTCHAI = ',PTCHAI C PRINT *,' CHAINE = ',CHAINE C PRINT *,'IARGUM = ',(IARGUM(I),I=1,NARGUM) C PRINT *,'LARGUM = ',(LARGUM(I),I=1,NARGUM) C C --- DEMANDE A L'UTILISATEUR DES PARAMETRES MANQUANTS --- IF( NARGUM.EQ.0 )THEN C --- MODE CONVERSATIONNEL ET COMMANDE SONT EXCLUSIFS --- CALL ESLARG(MESSAG,CHAINE,PTCHAI,NCARMX, > IARGUM,LARGUM,NARGUM,NARGAL,IERR) IF( IERR.NE.0)GOTO 9999 C PRINT *,' CHAINE = ',CHAINE C PRINT *,'IARGUM = ',(IARGUM(I),I=1,NARGUM) C PRINT *,'LARGUM = ',(LARGUM(I),I=1,NARGUM) ELSE C --- on complete les arguments par des ' ' (defaut) DO 50 I=NARGUM+1,NARGAL IARGUM(I)=PTCHAI LARGUM(I)=0 CHAINE(PTCHAI:)=' ' PTCHAI = PTCHAI+1 50 CONTINUE NARGUM = NARGAL ENDIF C --- CONVERSION ET ANALYSE --- CALL ESPLEX(CHAINE, > IARGUM,LARGUM,NARGUM, > ITYPEL,IOPTIO,MESSAG, > MOTS,LMOTS,NBMOTS,ICODES, > CHARTB,NBCHAR,INTETB,NBINTE,REALTB,NBREAL, > PRESEN,ITRACE,IERR) IF(IERR.NE.0)GOTO 9999 C --- VERIFICATION DE L'EXISTANCE DES FICHIERS --- DO 100 I=1,NARGUM C IF( IARGUM(I).EQ.-1 )GOTO 9999 IF( PRESEN(I).EQ.-1 )GOTO 100 CALL ESPEXF(CHARTB(IARGUM(I)),ITYPEL(I),MESSAG(I),ITRACE,IERR) IF(IERR.NE.0)GOTO 9999 100 CONTINUE C 9999 END C C REMARQUES : C 1. attention il faut faudra la difference entre 1 message C et un bout de texte ! C 2. Chaque module "independant" qui affiche ses propres messages C a une copie de XXMESS avec ses traductions ! C SUBROUTINE ESMESS(ITYPE,NUM1,NUM2,IMESS,IMESSL) C ***************************************************************** C OBJET ESMESS : construit le message IMESSL de code INUM dans la C langue definie (traduit le message IMESS) C ITYPE : type de message C -X : -1, -2, -3 messages d'erreur C 0 : warning C +X : message informatif C < 100 message informatif reserve (identitie) C 1 help on line C 2 C > 100 message quelconque C ***************************************************************** CHARACTER*(*) IMESS,IMESSL INTEGER ITYPE,NUM1,NUM2 C C character*63 helponline(5) character*512 helponline data helponline / >'ES is a fortran package that can be used as a library.'/ character*63 errmess(64) data errmess / C ------ FILE : es_geometrie.f C SUBROUTINE LITGEO & LITARE >' ', >'in a border definition ', >'in a border : incomplete definition ', >'too many zones on a border, must be less than ', >'too many nodes on a border, must be less than ', >'unknown code for border : ', >'in a border definition : number of nodes is not correct', >'in a border definition : number of zones is not correct', >'in a border definition : interval must begin with -3', C 10 >'in a border : the interval is empty', >'in a border : the type is unknown', C SUBROUTINE LITFRT >'in Block XYZ, wrong dimension ', >'Unknown : memory allocation?!', >'can t open the file : ', >'in Block XYZ : starting or ending tag is missing', >'in Block XYZ : number of points or dimension is wrong', >'at the point : ', >'in Block ARE ou ILM : number of borders or dimension is wrong', >'at the border : ', C 20 >'a point is wrong in the border :', >'dimension of the space must be > than the dimension of elements', >'in Block XYZ : dimension is too hight, must be less than : ', C SUBROUTINE ECRFRT >'the file already exist :', >'can t open the file : ', >'while writing the element :', C SUBROUTINE LITGRD >'in Block GRD : starting or ending tag missing', >'in Block GRD : number of values or dimension is wrong', >'at the value : ', C SUBROUTINE LITVIP >'in Block ILM : number of elements or dimension is wrong', C 30 >'at the element : ', >'too many points in the element, must be less than ', >'dimension of the space must be > than the dimension of elements', C SUBROUTINE ESGARG >'too many parameters for the application, must be <= ', >'too many character for a parameter, must be <= ', >'the following parameter is missing :', C SUBROUTINE ESEPRG : c'est une erreur (mais PB decalage) >'DATE ', >'CONTACT ', C SUBROUTINE ESLCHA >'not a string : ', >'not an integer : ', C 40 >'not a real : ', C SUBROUTINE LITTSN >'dimension of the values must be 1 instead of ', C SUBROUTINE LITRAF : c'est une erreur (mais PB decalage) >'-->DEFAULT MESH SIZE', >'-->READING MESH SIZE', >'-->DENSITY FUNCTIONS', >'-->NODAL VALUES', C SUBROUTINE LITDEN >'in Block GEO : starting or ending tag missing', >'in Block GEO : number of values or dimension is wrong', >'at the point : ', >'in Block SUI : starting or ending tag is missing', C 50 >'in Block SUI : number of progressions is not valid', >'at the progression : ', >'in Block DEN : starting or ending tag is missing', >'in Block DEN : number of concentrations or dimension is wrong', >'at the concentration : ', C SUBROUTINE STRDEN >'the concentration reference is not correct : ', >'the progression reference is not correct : ', >'the progression ratio is <= 0 : ', >'the progression size is <= 0 : ', >'the progression difference and size are <=0 : ', C 60 >'unknown type of concentration : ', >'illegal point reference number : ', C SUBROUTINE INIDEN >'no concentration defined !', C + LIVIP >'unknown type of element : ', >'123456789012345678901234567890123456789012345678901234567890123'/ character*63 messtype(5) data messtype / >'WARNING', >'DATA ERROR ', >'COMPUTER ERROR ', >'NOT YET POSSIBLE ', >'123456789012345678901234567890123456789012345678901234567890123'/ character*63 messages(10) data messages/ >' ', C SUBROUTINE LITRAF >'-->DEFAULT MESH SIZE', >'-->READING MESH SIZE', >'-->DENSITY FUNCTIONS', >'-->NODAL VALUES', C INIDEN >'Number of concentration : ', >'Mode of generation : ', C SUBROUTINE ESEPRG >'DATE ', >'CONTACT ', C 10 >'123456789012345678901234567890123456789012345678901234567890123'/ INTEGER LENCHR EXTERNAL LENCHR IF( ITYPE.LE.0 )THEN C --- entete IMESSL=messtype(1-ITYPE)(1:LENCHR(messtype(1-ITYPE))+1)//' ' >//errmess(NUM1)(1:LENCHR(errmess(NUM1)))//' ' >//errmess(NUM2)(1:LENCHR(errmess(NUM2)))//' ' C --- pour le debug : c write(*,*)ITYPE,NUM1,NUM2,IMESSL GOTO 9999 ENDIF c IF( ITYPE.LT.100 )THEN GOTO (10,20) ITYPE GOTO 1100 C ---- help on line ----- 10 CONTINUE IMESSL=helponline GOTO 1100 C --------- 20 CONTINUE GOTO 1100 1100 CONTINUE GOTO 9999 ENDIF IMESSL=messages(NUM1)(1:LENCHR(messages(NUM1)))// >' '//messages(NUM2)(1:LENCHR(messages(NUM2)))//' ' C --- pour le debug : c write(*,*)ITYPE,NUM1,NUM2,IMESSL GOTO 9999 9999 END C