Télécharger evol.eso

Retour à la liste

evol
C EVOL      SOURCE    CB215821  21/01/28    21:15:05     10867          
      SUBROUTINE EVOL
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C
C  OPERATEUR EVOL : EVOLUTION D'UN PARAMETRE EN FONCTION D'UN AUTRE
C  IL EXISTE 7 OPTIONS (VOIR SYNTAXES DANS LES ROUTINES CORRESPONDANTES)
C
C     :---------------------:---------------------------:
C     :        OPTION       :      ROUTINE              :
C     :---------------------:---------------------------:
C     :      SOLU           :       EVSOLU              :
C     :      MANU           :       EVMANU              :
C     :      RECO           :       EVRECO              :
C     :      PJBA           :       EVPJBA              :
C     :      COMP           :       EVCOMP              :
C     :      CHPO           :       EVCHPO              :
C     :      TEMP           :       EVTEMP              :
C     :---------------------:---------------------------:
C
C  ECRIT PAR FARVACQUE LE 22/10/85
C=======================================================================
 
-INC CCNOYAU
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMLMOTS
-INC SMLENTI
*
      PARAMETER(NDCLR=14)
      INTEGER IDCLR(NDCLR)
      DATA IDCLR/0,1,2,3,4,5,6,9,10,11,12,13,14,15/
*
      PARAMETER(LMOOPT=7)
      CHARACTER*4 MOOPT(LMOOPT)
      DATA MOOPT/'SOLU','MANU','RECO','PJBA','COMP','CHPO','TEMP'/
*
      CHARACTER*4 CHA4
      CHARACTER*8 CHA8
      CHARACTER*(LOCOMP) CMOT
      CHARACTER*(LONOM)  NCHPT,NMAIL
      POINTEUR LCOUL.MLENTI
*
*
*     ======================
*     COULEUR(S) DES COURBES
*     ======================
*
*     RECHERCHE SOUS FORME D'UN OBJET DE TYPE MOT OU LISTMOTS
      CALL LIRMOT(NCOUL,NBCOUL,IMCOUL,0)
*
*     UN MOT A ETE FOURNI => TOUTES LES COURBES SONT DE LA MEME COULEUR
      IF (IMCOUL.NE.0) THEN
         ICOUL=IMCOUL-1
         JG=1
         SEGINI,LCOUL
         LCOUL.LECT(1)=ICOUL
*
      ELSE
 
         ILCOUL=0
         CALL QUETYP(CHA8,1,IRET)
 
*        UN LISTMOTS A ETE FOURNI
         IF (CHA8.EQ.'LISTMOTS') THEN
            ILCOUL=1
            CALL LIROBJ('LISTMOTS',MLMOTS,1,IRET)
*
*           VERIFICATION DU NOMBRE DE COULEURS SPECIFIEES
            SEGACT,MLMOTS
            NCLR=MOTS(/2)
            IF (NCLR.EQ.0) THEN
               MOTERR(1:8)='LISTMOTS'
               CALL ERREUR(1027)
               RETURN
            ENDIF
*
*           VERIFICATION DES VALEURS FOURNIES ET TRANSFORMATION EN
*           LISTENTI
            JG=NCLR
            SEGINI,LCOUL
            NB1=0
            DO K=1,NCLR
               CHA4=MOTS(K)
               CALL CHRMOT(NCOUL,NBCOUL,CHA4,ICLR)
               IF (ICLR.EQ.0) THEN
                  MOTERR(1:4)=CHA4
                  CALL ERREUR(1055)
                  RETURN
               ENDIF
               LCOUL.LECT(K)=ICLR-1
            ENDDO
*
*        NI MOT NI LISTMOTS : UNE LISTE PAR DEFAUT EST UTILISEE
*        (COMMENCANT TOUJOURS PAR IDCOUL)
         ELSE
            JG=NDCLR
            SEGINI,LCOUL
            IDEF=0
            DO K=1,NDCLR
               IF (IDCLR(K).EQ.IDCOUL) IDEF=K
            ENDDO
            IF (IDEF.EQ.0) THEN
               LCOUL.LECT(1)=IDCOUL
               DO K=1,NDCLR-1
                  LCOUL.LECT(K+1)=IDCLR(K)
               ENDDO
            ELSE
               DO K=1,NDCLR
                  LCOUL.LECT(K)=IDCLR(MOD(K+IDEF-2,NDCLR)+1)
               ENDDO
            ENDIF
         ENDIF
*
         ICOUL=LCOUL.LECT(1)
      ENDIF
*
*
*     ===============================================================
*     MOT-CLE DE L'OPERATEUR EVOL ET BRANCHEMENT VERS LES SUBROUTINES
*     ===============================================================
*
      CALL LIRMOT(MOOPT,-LMOOPT,IVAL,1)
      IF (IERR.NE.0) GOTO 5000
      GOTO(1,2,3,4,5,6,7),IVAL
*
  1   CONTINUE
      CALL EVSOLU(ICOUL)
      GOTO 5000
*
  2   CONTINUE
      CALL EVMANU(ICOUL)
      GOTO 5000
*
  3   CONTINUE
      CALL EVRECO(LCOUL)
      GOTO 5000
*
  4   CONTINUE
      CALL EVPJBA(LCOUL)
      GOTO 5000
*
  5   CONTINUE
      CALL EVCOMP(ICOUL)
      GOTO 5000
*
  6   CONTINUE
C     SYNTAXE 'EVOL' 'CHPO'
C       LECTURE DU CHAMP-POINT
        CALL LIROBJ ('CHPOINT',IBOPOI,1,IRETOC)
        IF (IERR .NE. 0) RETURN
        CALL ACTOBJ('CHPOINT',IBOPOI,1)
        CALL QUENOM(NCHPT)
 
C       LECTURE DE LA COMPOSANTE
        CALL LIRCHA(CMOT,0,IRETOU)
        IF(IRETOU .EQ. 0) CMOT =' '
 
C       LECTURE DE L'OBJET MAILLAGE
        CALL LIROBJ('MAILLAGE',IPOI,1,IRETOM)
        IF (IERR .NE. 0) RETURN
        CALL ACTOBJ('MAILLAGE',IPOI,1)
        CALL QUENOM(NMAIL)
 
        CALL EVCHPO(ICOUL,IBOPOI,IPOI,MEVOLL,CMOT,NCHPT,NMAIL)
        IF(IERR .NE. 0) RETURN
        CALL ACTOBJ('EVOLUTIO',MEVOLL,1)
        CALL ECROBJ('EVOLUTIO',MEVOLL)
        GOTO 5000
*
  7   CONTINUE
      CALL EVTEMP(LCOUL)
      GO TO 5000
*
 5000 CONTINUE
      SEGSUP,LCOUL
      END
 
 
 
 

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