Télécharger soravs.eso

Retour à la liste

soravs
C SORAVS    SOURCE    FANDEUR   22/03/10    21:15:05     11313          
      SUBROUTINE SORAVS
************************************************************************
* NOM         : soravs.eso
* DESCRIPTION : Sortie d'un CHPOINT et/ou d'un MCHAML (s'appuyant au
C               centres de gravité des éléments) avec le maillage
C               support au format AVS (Unstructured Cell Data, ASCII)
************************************************************************
* HISTORIQUE :  25/11/1994 : BULIK : création de la subroutine
* HISTORIQUE :  22/09/1995 : BULIK : ajout des options SUIT et TEMP
* HISTORIQUE :  21/12/1998 : COURTOIS : modif des sorties pour maillage
* HISTORIQUE :  12/02/2010 : GOUNAND : evite l'impression de *******
* HISTORIQUE :  07/06/2012 : JCARDO : ajout de l'extension .inp
*                                    + fermeture du fichier
* HISTORIQUE :
************************************************************************
* Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
* en cas de modification de ce sous-programme afin de faciliter
* la maintenance !
************************************************************************
* APPELÉ PAR : opérateur SORTir (prsort.eso)
************************************************************************
* ENTRÉES :: aucune
* SORTIES :: aucune (sur fichier uniquement)
************************************************************************
* SYNTAXE (GIBIANE) :
*
*    SORT 'AVS' (MAIL1) (CHPO1) (CHML1) ('SUIT') ('TEMP' FLOT1) ;
*
************************************************************************
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
-INC SMCHPOI
-INC SMCHAML
-INC SMLMOTS
 
      EXTERNAL LONG
 
      POINTEUR MAPOIN.MELEME, MAELEM.MELEME
      POINTEUR IPT10.MELEME, IPT11.MELEME
 
      POINTEUR NCMCHA.MLMOTS, NCCHPO.MLMOTS
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SEGMENT VALMCH
         REAL*8 RVAMCH(NBCMCH,NELMAI)
      END SEGMENT
C
C     Segment : VALeurs du MCHaml
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SEGMENT VALCHP
         REAL*8 RVACHP(NBCCHP,NBNMAP)
      END SEGMENT
C
C     Segment : VALeurs du CHPoint
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      SEGMENT IEQUIV
         INTEGER LEQUIV(IECART)
      END SEGMENT
 
      CHARACTER*8 MTYP
      CHARACTER*(LOCOMP) MOCOMP
 
      REAL*8 VALTEM
 
      LOGICAL SORMAI, SORCHP, SORMCH, EXISEL, CNDTN
 
      LOGICAL CMPINT
      EXTERNAL CMPINT
 
      PARAMETER(NBMCLE=2)
      CHARACTER*4 MTSCLE(NBMCLE)
 
      DATA MTSCLE/'SUIT','TEMP'/
 
      CHARACTER*(LOCHAI) FICAVS
      LOGICAL ZOPEN
 
      NCCHPO=0
      NCMCHA=0
      VALCHP=0
      VALMCH=0
      IEQUIV=0
 
      SORMAI=.FALSE.
      SORCHP=.FALSE.
      SORMCH=.FALSE.
 
C ... Recherche des objets à sortir ...
 
      CALL LIROBJ('MAILLAGE',IVAL,0,IRETOU)
      IF(IRETOU.EQ.1) THEN
 
         MELEME=IVAL
         SORMAI=.TRUE.
 
         MAELEM=MELEME
         EXISEL=.TRUE.
 
         MAPOIN=MAELEM
         CALL CHANGE(MAPOIN,1)
C    ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
 
      ENDIF
 
      CALL LIROBJ('MCHAML  ',IVAL,0,IRETOU)
      IF(IRETOU.EQ.1) THEN
 
         MCHELM=IVAL
         SORMCH=.TRUE.
 
         IF(.NOT.SORMAI) THEN
            CALL ECRCHA('MAIL')
            CALL ECROBJ('MCHAML  ',MCHELM)
            CALL EXTRAI
            CALL LIROBJ('MAILLAGE',MAELEM,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
            EXISEL=.TRUE.
 
            MAPOIN=MAELEM
            CALL CHANGE(MAPOIN,1)
C       ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
         ENDIF
 
      ENDIF
 
      CALL LIROBJ('CHPOINT ',IVAL,0,IRETOU)
      IF(IRETOU.EQ.1) THEN
         MCHPOI=IVAL
         SORCHP=.TRUE.
 
         IF((.NOT.SORMAI).AND.(.NOT.SORMCH)) THEN
            MAELEM=0
            EXISEL=.FALSE.
 
            CALL ECRCHA('MAIL')
            CALL ECROBJ('CHPOINT ',MCHPOI)
            CALL EXTRAI
            CALL LIROBJ('MAILLAGE',MAPOIN,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
            SEGACT MAPOIN
         ENDIF
 
      ENDIF
 
      IF((.NOT.SORMAI).AND.(.NOT.SORMCH).AND.(.NOT.SORCHP)) THEN
         CALL ERREUR(704)
         RETURN
      ENDIF
 
C ... Lecture des mots clés éventuels ...
 
      NBCGLO=0
      INOREW=0
 
 10   CALL LIRMOT(MTSCLE,NBMCLE,IRAN,0)
 
      IF(IRAN.EQ.1) INOREW=1
 
      IF(IRAN.EQ.2) THEN
         NBCGLO=1
         CALL LIRREE(VALTEM,1,IRETOU)
         IF(IERR.NE.0) GOTO 9999
cdebug         write(*,*) 'Le temps lu = ',VALTEM
      ENDIF
 
      IF(IRAN.NE.0) GOTO 10
 
C ... NELMAI = Nombre d'ÉLéments du MAIllage ...
      IF(EXISEL) THEN
         CALL ECROBJ('MAILLAGE',MAELEM)
         CALL NBEL
         CALL LIRENT(NELMAI,1,IRETOU)
         IF(IERR.NE.0) GOTO 9999
      ELSE
         NELMAI=0
      ENDIF
 
C ... NBNMAP = NomBre de Noeuds du MAPoin ...
      CALL ECROBJ('MAILLAGE',MAPOIN)
      CALL NBNO
      CALL LIRENT(NBNMAP,1,IRETOU)
      IF(IERR.NE.0) GOTO 9999
 
C ... Si le MAILLAGE et le MCHAML sont donnés, on vérifiera que le
C     MAILLAGE est un sous-ensemble du support du MCHAML ...
 
      IF(SORMAI.AND.SORMCH) THEN
 
C    ... IPT1 = support du MCHAML ...
         CALL ECRCHA('MAIL')
         CALL ECROBJ('MCHAML  ',MCHELM)
         CALL EXTRAI
         CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
         IF(IERR.NE.0) GOTO 9999
 
         CALL ECROBJ('MAILLAGE',IPT1)
         CALL NBEL
         CALL LIRENT(NELSMC,1,IRETOU)
         IF(IERR.NE.0) GOTO 9999
 
C    ... IPT2 = intersection du MAILLAGE et du support du MCHAML ...
C        Si les deux sont distincts, INTERS sortira une ERREUR,
C        on commence donc par une différence symétrique :
C        si sa taille = NELMAI + NELSMC, ils sont distincts ...
C    ... Le problème est que lorsque les deux sont égaux, PRDIFF
C        se plante car il ne veut pas sortir un maillage nul,
C        il lui manque une option NOVERIF. On commence donc par vérifier
C        si les deux nombres d'éléments sont égaux - si OUI, un danger
C        guette, on va donc regarder ça de plus près, sinon PRDIFF etc ...
C    ... CNDTN est un logique qui décrit l'égalité des deux maillages ...
         IF(NELMAI.EQ.NELSMC) THEN
            SEGACT MAELEM
            SEGACT IPT1
            NBEL1=MAELEM.NUM(/2)
            NBEL2=  IPT1.NUM(/2)
            IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
C          ... Le cas où les deux maillages sont simples ...
               NBNN1=MAELEM.NUM(/1)
               NBNN2=  IPT1.NUM(/1)
               IF((NBNN1.EQ.NBNN2).AND.(MAELEM.ITYPEL.EQ.IPT1.ITYPEL))
     &         THEN
                  ILONG=NBEL1*NBNN1
                  CNDTN=CMPINT(MAELEM.NUM(1,1),IPT1.NUM(1,1),ILONG)
               ELSE
                  CNDTN=.FALSE.
               ENDIF
            ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
C          ... Le cas où les deux maillages sont composés ...
               NBS1=MAELEM.LISOUS(/1)
               NBS2=  IPT1.LISOUS(/1)
               IF(NBS1.EQ.NBS2) THEN
                  CNDTN=.TRUE.
                  DO 1100 I=1,NBS1
                     IPT10=MAELEM.LISOUS(I)
                     IPT11=  IPT1.LISOUS(I)
                     SEGACT IPT10
                     SEGACT IPT11
                     IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
     &                  (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
     &                  (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
                        ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
                        CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
     &                                         IPT11.NUM(1,1),ILONG)
                     ELSE
                        CNDTN=.FALSE.
                     ENDIF
                     SEGDES IPT10
                     SEGDES IPT11
 1100             CONTINUE
               ELSE
                  CNDTN=.FALSE.
               ENDIF
            ELSE
C          ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
C              probable quoique pas exclu que les deux maillages soient
C              égaux, on met donc CoNDiTioN à FAUX ...
               CNDTN=.FALSE.
            ENDIF
            SEGDES MAELEM
            SEGDES IPT1
         ELSE
            CNDTN=.FALSE.
         ENDIF
 
         IF(CNDTN) THEN
            NELDS=0
         ELSE
            CALL ECROBJ('MAILLAGE',MAELEM)
            CALL ECROBJ('MAILLAGE',IPT1)
            CALL PRDIFF
            CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
 
            CALL ECROBJ('MAILLAGE',IPT2)
            CALL NBEL
            CALL LIRENT(NELDS,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
         ENDIF
 
         IF(NELDS.EQ.NELMAI+NELSMC) THEN
            IPT2=0
            NELINT=0
         ELSE
            CALL ECROBJ('MAILLAGE',MAELEM)
            CALL ECROBJ('MAILLAGE',IPT1)
            CALL INTERS
            CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
 
C       ... NELINT = nombre d'éléments de l'INTersection IPT2 ...
            CALL ECROBJ('MAILLAGE',IPT2)
            CALL NBEL
            CALL LIRENT(NELINT,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
         ENDIF
 
C    ... S'il n'y pas égalité, MAILLAGE n'est pas un sous ensemble ...
         IF(NELINT.NE.NELMAI) THEN
            CALL ERREUR(706)
            GOTO 10000
         ENDIF
 
C    ... Maintenant on réduit le MCHAML su MELEME pour être sûr de
C        l'ordre des éléments ...
         CALL REDUIC(MCHELM,MELEME,IRETOU)
         IF(IRETOU.EQ.0) THEN
            GOTO 9999
         ELSE
            MCHELM=IRETOU
         ENDIF
 
C    ... Maintenant MCHELM est consistant avec MAELEM et MAPOIN ...
C    ... Il reste deux maillages comme effet (IPT1, IPT2) ...
 
      ENDIF
 
C ... Si le MAILLAGE (ou MCHAML) et le CHPOINT sont présents, on vérifiera que
C     le MAILLAGE et le support du CHPOINT ont une partie commune ...
 
      IF((SORMAI.OR.SORMCH).AND.SORCHP) THEN
 
C    ... IPT3 = support du CHPOINT ...
         CALL ECRCHA('MAIL')
         CALL ECROBJ('CHPOINT  ',MCHPOI)
         CALL EXTRAI
         CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
         IF(IERR.NE.0) GOTO 9999
 
C    ... NNSCHP = Nombre de Noeuds du Support du CHPoint ...
         CALL ECROBJ('MAILLAGE',IPT3)
         CALL NBNO
         CALL LIRENT(NNSCHP,1,IRETOU)
         IF(IERR.NE.0) GOTO 9999
 
C    ... Pour les explications de cette partie voir la partie
C        équivalente ci-dessus, au niveau du traitement du MCHAML ...
         IF(NBNMAP.EQ.NNSCHP) THEN
            SEGACT MAPOIN
            SEGACT IPT3
            NBEL1=MAPOIN.NUM(/2)
            NBEL2=  IPT3.NUM(/2)
            IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
C          ... Le cas où les deux maillages sont simples ...
               NBNN1=MAPOIN.NUM(/1)
               NBNN2=  IPT3.NUM(/1)
               IF((NBNN1.EQ.NBNN2).AND.(MAPOIN.ITYPEL.EQ.IPT3.ITYPEL))
     &         THEN
                  ILONG=NBEL1*NBNN1
                  CNDTN=CMPINT(MAPOIN.NUM(1,1),IPT3.NUM(1,1),ILONG)
               ELSE
                  CNDTN=.FALSE.
               ENDIF
            ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
C          ... Le cas où les deux maillages sont composés ...
               NBS1=MAPOIN.LISOUS(/1)
               NBS2=  IPT3.LISOUS(/1)
               IF(NBS1.EQ.NBS2) THEN
                  CNDTN=.TRUE.
                  DO 1200 I=1,NBS1
                     IPT10=MAPOIN.LISOUS(I)
                     IPT11=  IPT3.LISOUS(I)
                     SEGACT IPT10
                     SEGACT IPT11
                     IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
     &                  (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
     &                  (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
                        ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
                        CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
     &                                         IPT11.NUM(1,1),ILONG)
                     ELSE
                        CNDTN=.FALSE.
                     ENDIF
                     SEGDES IPT10
                     SEGDES IPT11
 1200             CONTINUE
               ELSE
                  CNDTN=.FALSE.
               ENDIF
            ELSE
C          ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
C              probable quoique pas exclu que les deux maillages soient
C              égaux, on met donc CoNDiTioN à FAUX ...
               CNDTN=.FALSE.
            ENDIF
            SEGDES MAPOIN
            SEGDES IPT3
         ELSE
            CNDTN=.FALSE.
         ENDIF
 
         IF(CNDTN) THEN
            NNDS=0
         ELSE
C       ... IPT4 = ici à la différence symétrique du MAPOIN et du support du CHPOINT ...
            CALL ECROBJ('MAILLAGE',MAPOIN)
            CALL ECROBJ('MAILLAGE',IPT3)
            CALL PRDIFF
            CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
 
            CALL ECROBJ('MAILLAGE',IPT4)
            CALL NBNO
            CALL LIRENT(NNDS,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
         ENDIF
 
C    ... IPT4 = intersection du MAPOIN et du support du CHPOINT ...
         IF(NNDS.EQ.NBNMAP+NNSCHP) THEN
            IPT4=0
            NBNIN4=0
         ELSE
            CALL ECROBJ('MAILLAGE',MAPOIN)
            CALL ECROBJ('MAILLAGE',IPT3)
            CALL INTERS
            CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
 
C       ... NBNIN4 = NomBre de Noeuds de l'INtersection ipt4 ...
            CALL ECROBJ('MAILLAGE',IPT4)
            CALL NBNO
            CALL LIRENT(NBNIN4,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
         ENDIF
 
         IF(NBNIN4.EQ.0) THEN
C       ... Quand NBNIN4=0 -> cas No 1 ...
            SORCHP=.FALSE.
            CALL ERREUR(-297)
            CALL ERREUR(-296)
         ELSE IF(NBNIN4.EQ.NBNMAP) THEN
C       ... Si NBNIN4=NBNMAP (cas 2), il faut réduire le CHPOINT sur le maillage ...
            CALL REDUIR(MCHPOI,MAPOIN,IRETOU)
            IF(IRETOU.EQ.0) THEN
               GOTO 9999
            ELSE
               MCHPOI=IRETOU
            ENDIF
         ELSE IF (NBNIN4.EQ.NNSCHP) THEN
C       ... Cas No 4 - le support du CHPOINT est entièrement contenu dans le
C           maillage, donc on ne fait rien ...
         ELSE
C       ... Sinon, c'est le cas 3, il faut donc "aggrandir" le CHPOINT,
C           en fait on va le réduire sur l'intersection IPT4, ceci pour
C           éliminer les composantes dont le support est en dehors du maillage ...
            CALL REDUIR(MCHPOI,IPT4,IRETOU)
            IF(IRETOU.EQ.0) THEN
               GOTO 9999
            ELSE
               MCHPOI=IRETOU
            ENDIF
         ENDIF
 
      ENDIF
 
C ... Puisqu'on ne sort que certains noeuds il faut transformer les
C     connectivités, pour ceci on se servira du SEGMENT IEQUIV ...
 
C ... Recherche des numéros maxi et mini des noeuds dont on a besoin ...
 
      SEGACT MAPOIN
      NBELEM=MAPOIN.NUM(/2)
      NBNN=MAPOIN.NUM(/1)
      IF(NBELEM.EQ.NBNMAP) THEN
 
         IF(NBNN.NE.1) GOTO 9999
         IPTMIN=MAPOIN.NUM(1,1)
         IPTMAX=MAPOIN.NUM(1,1)
         DO 1500 I=1,NBELEM
            IF(MAPOIN.NUM(1,I).LT.IPTMIN) IPTMIN=MAPOIN.NUM(1,I)
            IF(MAPOIN.NUM(1,I).GT.IPTMAX) IPTMAX=MAPOIN.NUM(1,I)
 1500    CONTINUE
 
      ELSE IF(NBELEM.EQ.0) THEN
 
         NBSOUS=MAPOIN.LISOUS(/1)
         DO 1505 I=1,NBSOUS
            IPT5=LISOUS(I)
            SEGACT IPT5
            NBNTMP=IPT5.NUM(/1)
            NBETMP=IPT5.NUM(/2)
            IF(NBNTMP.NE.1) GOTO 9999
            IF(I.EQ.1) THEN
               IPTMIN=IPT5.NUM(1,1)
               IPTMAX=IPT5.NUM(1,1)
            ENDIF
            DO 1506 J=1,NBETMP
               IF(IPT5.NUM(1,J).LT.IPTMIN) IPTMIN=IPT5.NUM(1,J)
               IF(IPT5.NUM(1,J).GT.IPTMAX) IPTMAX=IPT5.NUM(1,J)
 1506       CONTINUE
            SEGDES IPT5
 1505    CONTINUE
 
      ENDIF
 
C ... Initialisation du segment IEQUIV ...
 
      IECART=IPTMAX-IPTMIN+1
      SEGINI IEQUIV
 
C ... et son remplissage ...
 
      IF(NBELEM.EQ.NBNMAP) THEN
 
         DO 1510 I=1,NBELEM
            LEQUIV(MAPOIN.NUM(1,I)-IPTMIN+1)=I
 1510    CONTINUE
 
      ELSE IF(NBELEM.EQ.0) THEN
 
         NBSOUS=MAPOIN.LISOUS(/1)
         K=0
         DO 1515 I=1,NBSOUS
            IPT5=LISOUS(I)
            SEGACT IPT5
            NBNTMP=IPT5.NUM(/1)
            NBETMP=IPT5.NUM(/2)
            IF(NBNTMP.NE.1) GOTO 9999
            DO 1516 J=1,NBETMP
               K=K+1
C          ... Ici je suppose que chaque point n'est représenté qu'une
C              seule fois dans MAPOIN. En conséquence, dans la ligne en dessous
C              je n'ai pas mis de test si LEQUIV(IPT5.NUM(1,J)-IPTMIN+1) est
C              différent de zéro ...
               LEQUIV(IPT5.NUM(1,J)-IPTMIN+1)=K
 1516       CONTINUE
            SEGDES IPT5
 1515    CONTINUE
 
      ENDIF
 
C ... Préparation de la première ligne du fichier AVS, on connaît déjà
C     les nombres de noeuds et d'éléments, il manque les nombres de composantes
C     du CHPOINT et du MCHAML (s'ils sont présents) ...
 
C ... On commence par le MCHAML ...
      IF(SORMCH) THEN
         CALL EXTR17(MCHELM,NCMCHA)
         SEGACT NCMCHA
         NBCMCH=NCMCHA.MOTS(/2)
ccc         SEGDES NCMCHA
      ELSE
         NBCMCH=0
      ENDIF
 
C ... Et ensuite c'est le tour du CHPOINT ...
      IF(SORCHP) THEN
         CALL EXTR11(MCHPOI,NCCHPO)
         SEGACT NCCHPO
         NBCCHP=NCCHPO.MOTS(/2)
ccc         SEGDES NCCHPO
      ELSE
         NBCCHP=0
      ENDIF
 
C ... Maintenant on va remplir des segments contenant toutes les valeurs
C     et composantes du MCHAML et du CHPOINT en un seul morceau ...
 
C ... On commence par le MCHAML ...
C ... On va vérifier aussi qu'il y a une seule valeur par élément ...
      IF(SORMCH) THEN
C    ... On ne le met pas à zero car toutes les cases vont etre remplies ...
         SEGINI VALMCH
         SEGACT MCHELM
         N1=ICHAML(/1)
C    ... IDECNE = DECalage des Numéros d'Eléments ...
         IDECNE=0
C    ... Boucle sur les zones élémentaires, dont chacune possède son ...
         DO 1600 I=1,N1
C       ... segment MCHAML ...
            MCHAML=ICHAML(I)
            SEGACT MCHAML
            N2=IELVAL(/1)
C       ... et le maillage support ...
            IPT6=IMACHE(I)
            CALL ECROBJ('MAILLAGE',IPT6)
            CALL NBEL
            CALL LIRENT(NELSMC,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
C       ... Boucle sur les composantes du MCHAML ...
            DO 1610 J=1,N2
               MOCOMP=NOMCHE(J)
               IF(TYPCHE(J).NE.'REAL*8          ') THEN
                  MOTERR(1:8)=MOCOMP
                  CALL ERREUR(679)
                  GOTO 10000
               ENDIF
C          ... Maintenant on cherche la position du nom de la composante No J
C              dans NCMCHA ...
               DO 1620 K=1,NBCMCH
                  IF(NCMCHA.MOTS(K).EQ.MOCOMP) GOTO 1630
 1620          CONTINUE
 1630          CONTINUE
C          ... K est maintenant le numéro de la composante J dans NCMCHA ...
               MELVAL=IELVAL(J)
               SEGACT MELVAL
               N1PTEL=VELCHE(/1)
               N1EL  =VELCHE(/2)
               IF(N1PTEL.NE.1) THEN
                  CALL ERREUR(707)
                  GOTO 10000
               ENDIF
C          ... Si N1EL==1 c'est un champ constant ...
               IF(N1EL.EQ.1) THEN
                  DO 1680 L=1,NELSMC
                     RVAMCH(K,L+IDECNE)=VELCHE(1,1)
 1680             CONTINUE
               ELSE IF(N1EL.EQ.NELSMC) THEN
                  DO 1660 L=1,NELSMC
                     RVAMCH(K,L+IDECNE)=VELCHE(1,L)
 1660             CONTINUE
               ELSE
                  MOTERR(1:8)='MCHAML  '
                  CALL ERREUR(708)
                  GOTO 10000
               ENDIF
               SEGDES MELVAL
 1610       CONTINUE
            IDECNE=IDECNE+NELSMC
            SEGDES MCHAML
 1600    CONTINUE
         SEGDES MCHELM
      ENDIF
 
C ... Remplissage des valeurs du CHPOINT ...
      IF(SORCHP) THEN
 
         SEGINI VALCHP
CDEBUG      WRITE(IOIMP,*) 'NBCCHP = ',NBCCHP
CDEBUG      WRITE(IOIMP,*) 'NBNMAP = ',NBNMAP
         DO 1700 I=1,NBCCHP
            DO 1701 J=1,NBNMAP
               RVACHP(I,J)=0.D0
 1701       CONTINUE
 1700    CONTINUE
 
         SEGACT MCHPOI
         NSOUPO=IPCHP(/1)
C    ... IDECNP = DECalage des Numéros de Points ...
C inutile         IDECNP=0
C    ... Boucle sur les sous-zones du CHPOINT dont chacune est définie par ...
         DO 1710 I=1,NSOUPO
C       ... un segment MSOUPO ...
CDEBUG      WRITE(IOIMP,*) 'Sous-zone No ',I
            MSOUPO=IPCHP(I)
            SEGACT MSOUPO
            NC=NOHARM(/1)
C       ... son support géométrique ...
            IPT7=IGEOC
      CALL NOMOBJ('MAILLAGE','MASUPCHP',IPT7)
            CALL ECROBJ('MAILLAGE',IPT7)
            CALL NBNO
            CALL LIRENT(NPOSCH,1,IRETOU)
            IF(IERR.NE.0) GOTO 9999
            SEGACT IPT7
CDEBUG      WRITE(IOIMP,*) '  -> ',NPOSCH,' noeuds'
CDEBUG      WRITE(IOIMP,*) 'IPT7 : ITYPEL = ',IPT7.ITYPEL
CDEBUG      WRITE(IOIMP,*) 'IPT7 : NBELEM = ',IPT7.NUM(/2)
C       ... et ses valeurs ...
            MPOVAL=IPOVAL
            SEGACT MPOVAL
            N=VPOCHA(/1)
            IF(N.NE.NPOSCH) THEN
               MOTERR(1:8)='CHPOINT '
               CALL ERREUR(708)
               GOTO 10000
            ENDIF
C       ... Boucle sur les composantes du CHPOINT ...
            DO 1720 J=1,NC
C          ... dont on cherche la place dans NCCHPO ...
               MOCOMP=NOCOMP(J)
               DO 1730 K=1,NBCCHP
                  IF(NCCHPO.MOTS(K).EQ.MOCOMP) GOTO 1740
 1730          CONTINUE
 1740          CONTINUE
C          ... Maintenant K pointe le NOCOMP(J) dans NCCHPO ...
CDEBUG      WRITE(IOIMP,*) 'Composante No',J,' correspond à K = ',K
C          ... Maintenant il faut parcourir les noeuds du support du CHPOINT ...
C          ... Si ce support est un maillage élémentaire, ceci est simple ...
               IF(IPT7.NUM(/2).GT.0) THEN
CDEBUG      WRITE(IOIMP,*) 'Support = Maillage élémentaire'
                  DO 1750 L=1,N
C                ... ça ne marchera pas dans le cas général, car l'ordre des n'est pas
C                    forcément le meme dans le MAPOIN et dans le support du CHPOINT ...
C                    RVACHP(K,L+IDECNP)=VPOCHA(L,J) ...
C                ... il faut chercher la position du noeud ...
                     NNSCHP=IPT7.NUM(1,L)
                     IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
                        NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
                     ELSE
                        NNMAPO=0
                     ENDIF
CDEBUG      WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
                     IF(NNMAPO.NE.0) RVACHP(K,NNMAPO)=VPOCHA(L,J)
 1750             CONTINUE
C          ... Sinon on va s'amuser ...
               ELSE
CDEBUG      WRITE(IOIMP,*) 'Support = Maillage composé'
                  L=0
                  NBSOUS=IPT7.LISOUS(/1)
                  DO 1765 M=1,NBSOUS
                     IPT8=IPT7.LISOUS(M)
                     SEGACT IPT8
                     NBELEM=IPT8.NUM(/2)
CDEBUG      WRITE(IOIMP,*) 'IPT8 : ITYPEL = ',IPT8.ITYPEL
CDEBUG      WRITE(IOIMP,*) 'IPT8 : NBELEM = ',NBELEM
                     DO 1770 MM=1,NBELEM
                        L=L+1
                        NNSCHP=IPT8.NUM(1,MM)
                        IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
                           NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
                        ELSE
                           NNMAPO=0
                        ENDIF
CDEBUG      WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
                        IF(NNMAPO.NE.0) RVACHP(K,NNMAPO)=VPOCHA(L,J)
 1770                CONTINUE
                     SEGDES IPT8
 1765             CONTINUE
               ENDIF
 1720       CONTINUE
C inutile            IDECNP=IDECNP+NPOSCH
            SEGDES MPOVAL
            SEGDES MSOUPO
            SEGDES IPT7
 1710    CONTINUE
         SEGDES MCHPOI
 
      ENDIF
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C           ... Sortie au format AVS ...
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
 
*     Récupération du nom du fichier et ajout de l'extension au
*     nom du fichier
      INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
      IF (.NOT.ZOPEN) THEN
          CALL ERREUR(-212)
          WRITE(IOIMP,*) '(via OPTI "SORT")'
          MOTERR(1:8)='AVS     '
          CALL ERREUR(705)
          RETURN
      ENDIF
 
*     Quel est le nom du fichier ouvert ?
      INQUIRE(UNIT=IOPER,NAME=FICAVS)
 
*     Si pas d'extension .inp, on le réouvre
      CALL LENCHA(FICAVS,LC)
      IF (FICAVS(LC-3:LC).NE.'.inp') THEN
          CLOSE(UNIT=IOPER,STATUS='DELETE')
          IF (LC+4.GT.LOCHAI) THEN
            write(ioimp,*) 'AVS Filename too long with extension' 
            CALL ERREUR(1111)
            RETURN
          ENDIF
          FICAVS(LC+1:LC+4)='.inp'
          IOS=0
          OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICAVS(1:LONG(FICAVS)),
     &         IOSTAT=IOS,FORM='FORMATTED')
      ENDIF
 
*     Pas d'option 'SUIT' => on rembobine
      IF (INOREW.EQ.0) REWIND IOPER
 
C ... Ligne de tete ...
      WRITE(IOPER,4000) NBNMAP,NELMAI,NBCCHP,NBCMCH,NBCGLO
 
C ... On active le segment MCOORD au cas ou !
      SEGACT,MCOORD*NOMOD
 
C ... Les noeuds ... MAPOIN est un MELEME de POI1
      SEGACT MAPOIN
      IDIMP1 = IDIM + 1
      IF (IDIM.EQ.3) THEN
         DO I=1,NBNMAP
            NUMNO=(MAPOIN.NUM(1,I)-1)*IDIMP1
            WRITE(IOPER,4010) I,XCOOR(NUMNO+1),XCOOR(NUMNO+2),
     &                          XCOOR(NUMNO+3)
         ENDDO
      ELSE IF (IDIM.EQ.2) THEN
         DO I=1,NBNMAP
            NUMNO=(MAPOIN.NUM(1,I)-1)*IDIMP1
            WRITE(IOPER,4010) I,XCOOR(NUMNO+1),XCOOR(NUMNO+2),0.D0
        ENDDO
      ELSE IF (IDIM.EQ.1) THEN
         DO I=1,NBNMAP
            NUMNO=(MAPOIN.NUM(1,I)-1)*IDIMP1
            WRITE(IOPER,4010) I,XCOOR(NUMNO+1),0.D0,0.D0
        ENDDO
      ENDIF
      SEGDES MAPOIN
 
C ... Le maillage ...
      IDECAL=0
      IF(EXISEL) THEN
         SEGACT MAELEM
         NBELEM=MAELEM.NUM(/2)
         IF(NBELEM.GT.0) THEN
            LESOUS = MAELEM
            CALL AVSMEL(LESOUS,IDECAL,1,IEQUIV,IPTMIN)
         ELSE
            NBSOUS=MAELEM.LISOUS(/1)
            DO 2100 I=1,NBSOUS
               LESOUS=MAELEM.LISOUS(I)
               CALL AVSMEL(LESOUS,IDECAL,I,IEQUIV,IPTMIN)
 2100       CONTINUE
         ENDIF
         SEGDES MAELEM
      ENDIF
 
C ... Le CHPOINT ...
      IF(SORCHP) THEN
C    ... On commence par les noms des composantes ...
         WRITE(IOPER,4030) NBCCHP,(1,K=1,NBCCHP)
C+DC
         DO 2101 I=1,NBCCHP
           WRITE(IOPER,4042) (NCCHPO.MOTS(I))
 2101    CONTINUE
C
         SEGSUP NCCHPO
 
C    ... Et ensuite leurs valeurs ...
         DO 2200 I=1,NBNMAP
            WRITE(IOPER,4050) I,(RVACHP(K,I),K=1,NBCCHP)
 2200    CONTINUE
         SEGSUP VALCHP
      ENDIF
 
C ... Le MCHAML ...
      IF(SORMCH) THEN
C    ... On commence par les noms des composantes ...
         WRITE(IOPER,4030) NBCMCH,(1,K=1,NBCMCH)
         WRITE(IOPER,4043) (NCMCHA.MOTS(I),I=1,NBCMCH)
         SEGSUP NCMCHA
 
C    ... Et ensuite leurs valeurs ...
         DO 2300 I=1,NELMAI
            WRITE(IOPER,4050) I,(RVAMCH(K,I),K=1,NBCMCH)
 2300    CONTINUE
         SEGSUP VALMCH
      ENDIF
 
C ... Le champ global ...
 
      IF(NBCGLO.EQ.1) THEN
         WRITE(IOPER,4030) 1,1
         WRITE(IOPER,4040) 'time'
         WRITE(IOPER,4050) 1,VALTEM
      ENDIF
 
C ... Le ménage ...
 
      SEGSUP IEQUIV
 
*     Pas d'option 'SUIT' => Fermeture du fichier
      IF (INOREW.EQ.0) CLOSE(UNIT=IOPER)
 
C ... Il n'y a pas de champ global, donc ...
 
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C  ... Fin de la partie où tout se passe bien ...
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
 9999 CONTINUE
      MOTERR(1:8)='AVS     '
      CALL ERREUR(705)
 
10000 CONTINUE
      IF(NCCHPO.NE.0) THEN
         SEGSUP NCCHPO
      ENDIF
      IF(NCMCHA.NE.0) THEN
         SEGSUP NCMCHA
      ENDIF
      IF(VALCHP.NE.0) THEN
         SEGSUP VALCHP
      ENDIF
      IF(VALMCH.NE.0) THEN
         SEGSUP VALMCH
      ENDIF
      IF(IEQUIV.NE.0) THEN
         SEGSUP IEQUIV
      ENDIF
 
      RETURN
 
 4000 FORMAT(5I11)
 4010 FORMAT(I11,3(1X,1P,1E20.13))
 4020 FORMAT(2I11,'    pt',I11)
 4030 FORMAT(13I11)
 4040 FORMAT(1X,A4,',')
 4041 FORMAT(1X,A8,',')
C Modif DC 12/2006 - Sortie AVS compatible PARAVIEW
 4042 FORMAT(1X,A8,',1 ')
 4043 FORMAT(1X,A8,',1 1')
C+ Fin modif
 4050 FORMAT(I11,12(1X,1P,E20.13))
 
      END
 
 
 

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