Télécharger crevlc.eso

Retour à la liste

crevlc
C CREVLC    SOURCE    CB215821  22/08/22    21:15:02     11429          
      SUBROUTINE CREVLC(ILREE1,ILCHP1,IMAIL1,ILMOT1,ILMOT2,TITR1,IEVOL1)                                                  
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)                                                  
************************************************************************
* NOM         : CREVLC
* DESCRIPTION : Cree un objet EVOLUTION a partir d'un LISTCHPO, un
*               MAILLAGE et un LISTMOTS pour les ordonnees et d'un
*               LISTREEL pour les abscisses
************************************************************************
* APPELE PAR : evresu.eso ; evreco.eso
************************************************************************
* ENTREES : ILREE1 = pointeur vers le LISTREEL des abscisses
*           ILCHP1 = pointeur vers le LISTCHPO des ordonnees
*           IMAIL1 = pointeur vers le MELEME de POI1
*           ILMOT1 = pointeur vers le LISTMOTS des composantes
*                    (0 si non specifie)
*           ILMOT2 = pointeur vers le LISTMOTS des couleurs des courbes
*           TITR1  = titre de l'ensemble des courbes
* SORTIES : IEVOL1 = pointeur vers l'objet EVOLUTIO
************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMELEME
-INC SMLENTI
-INC SMLREEL
-INC SMLMOTS
-INC SMLCHPO
*
      POINTEUR LCOUL.MLENTI
      POINTEUR LCOMP.MLMOTS
      POINTEUR LNOMS.MLMOTS
*
      CHARACTER*(LOCOMP) MOCMP1
      CHARACTER*8  CHA8
      CHARACTER*10 CH10
      CHARACTER*16 CH16
      CHARACTER*72 TITR1,FMT1
*
*
*     ======================
*     LISTREEL DES ABSCISSES
*     ======================
*
      MLREEL=ILREE1
      SEGACT,MLREEL
      NT=PROG(/1)
*
*
*     ======================
*     LISTCHPO DES ORDONNEES
*     ======================
*
      MLCHPO=ILCHP1
      SEGACT,MLCHPO
      IF (ICHPOI(/1).NE.NT) THEN
         CALL ERREUR(212)
         RETURN
      ENDIF      
*
*
*     =========
*     GEOMETRIE
*     =========
*
      MELEME=IMAIL1
      SEGACT,MELEME
      IF (LISOUS(/1).NE.0.OR.ITYPEL.NE.1) CALL CHANGE(MELEME,1)
      SEGACT,MELEME
      NPO=NUM(/2)
      IF (NPO.EQ.0) THEN
         MOTERR(1:8)='MAILLAGE'
         CALL ERREUR(1027)
         RETURN
      ENDIF
*
*
*     ========================
*     LISTE DES NOMS DE POINTS
*     ========================
*
      JGM=NPO
      JGN=16
      SEGINI,LNOMS
      DO I=1,NPO
         IPO1=NUM(1,I)
         CALL SKNAME(IPO1,CHA8,IRETOU,1)
*
*        ON A TROUVE UN NOM DANS LA LISTE DES OBJETS NOMMES
         IF (IRETOU.NE.0) THEN
            LNOMS.MOTS(I)=CHA8
*
*        SINON, CREATION D'UN NOM PAR DEFAUT
         ELSE
            WRITE(CH10,FMT='(I10)') IPO1
            CALL LIMCHA(CH10,I1,I2)
            WRITE(CH16,FMT='("POINT#",A)') CH10(I1:I2)
            LNOMS.MOTS(I)=CH16
         ENDIF
      ENDDO
*
*
*     =====================
*     LISTE DES COMPOSANTES
*     =====================
*
      LCOMP=ILMOT1     
      IF (LCOMP.NE.0) THEN
         SEGACT,LCOMP
         NCO=LCOMP.MOTS(/2)
      ELSE
         NCO=1
      ENDIF     
*
*
*     ==================
*     LISTE DES COULEURS
*     ==================
*
      LCOUL=ILMOT2
      SEGACT,LCOUL
      NCLR=LCOUL.LECT(/1)
*
*     ON COMPLETE SI BESOIN LA LISTE DES COULEURS
      NEV=NCO*NPO
      IF (NEV.GT.NCLR) THEN
         JG=NEV
         SEGADJ,LCOUL
         DO K=NCLR+1,NEV
            LCOUL.LECT(K)=LCOUL.LECT(K-NCLR)
         ENDDO
      ENDIF
*
*
*     ====================
*     CREATION DES COURBES
*     ====================
*
      N=NEV
      SEGINI,MEVOLL
      IEVOL1=MEVOLL
      ITYEVO='REEL'
      IEVTEX=TITR1
      DO INO=1,NPO
         SEGACT,MELEME
         IPO1=NUM(1,INO)
*
         CALL EXTR24(ILCHP1,LCOMP,IPO1,ILREE2)
         MLREE2=ILREE2
         SEGACT,MLREE2
         IF (MLREE2.PROG(/1)/NCO.NE.NT) THEN
            MOTERR(1:8)='CREVLC'
            CALL ERREUR(1039)
            RETURN
         ENDIF
*         
         DO ICO=1,NCO
*
            IF (NCO.EQ.1) THEN
               ILREEY=ILREE2
            ELSE
               JG=NT
               SEGINI,MLREE3
               ILREEY=MLREE3
               IT1=(ICO-1)*NT
               DO IT=1,NT
                  MLREE3.PROG(IT)=MLREE2.PROG(IT1+IT)
               ENDDO
            ENDIF
*
            IEV=(INO-1)*NCO+ICO
            SEGINI,KEVOLL
            IEVOLL(IEV)=KEVOLL
            TYPX='LISTREEL'
            TYPY='LISTREEL'
            IPROGX=ILREE1
            IPROGY=ILREEY
            NUMEVX=LCOUL.LECT(IEV)
            NUMEVY='REEL' 
            NOMEVX='TEMPS'
            if (lcomp.ne.0) then
             MOCMP1=LCOMP.MOTS(ICO)
             NOMEVY = MOCMP1
            endif
            IF (NCO.EQ.1) THEN
               KEVTEX=LNOMS.MOTS(INO)
            ELSE
               CH16=LNOMS.MOTS(INO)
               CALL LENCHA(CH16,LN)
               FMT1='(A," COMP. ",' // FMCOMP(2:4)
               WRITE(KEVTEX,FMT=FMT1) CH16(1:LN),MOCMP1
            ENDIF
         ENDDO
*
         IF (NCO.NE.1) SEGSUP,MLREE2
*
      ENDDO
      SEGSUP,LNOMS
*
      RETURN
*
      END
*
* 
 
 
 
 

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