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