C TEVOLU SOURCE OF166741 25/02/20 21:17:45 12165 SUBROUTINE TEVOLU(IEVO,TI) C C ===================================================================== C C Options (PAS) AVANT et APRES à l'opération EXTR EVOL1 C (aggiunta opzione INDI per mots AVAN, APRE; arede 14.09.94)--- C C ===================================================================== C C CREATION : 14.09.94 C PROGRAMMEUR : ? C Modification : PM 12/09/2007, C définition de la couleur et du type de l'évolution C extraite C BP, 2015-10-16 : ajout option COMPris C C ===================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL CHARACTER*(*) TI CHARACTER*(4) TI_4 SEGMENT WEVOX(0) SEGMENT WEVOY(0) C PARAMETER (IOPZ=4) CHARACTER*(4) MOPZ(IOPZ) CHARACTER*(4) MOINDI(1) CHARACTER*(4) MOZERO(1) DATA MOPZ /'PAS ','AVAN','APRE','COMP'/ DATA MOINDI/'INDI'/ DATA MOZERO/'ZERO'/ ************************************************************************ * Activation et aiguillage ************************************************************************ TI_4 = TI(1:4) MEVOL1=IEVO DO IMOT=1,IOPZ IF(TI_4.EQ.MOPZ(IMOT)) GOTO (10,20,20,30),IMOT ENDDO CALL ERREUR(5) GOTO 900 ************************************************************************ * option 'PAS' * Extraction d'une valeur toutes les J ************************************************************************ * 10 CONTINUE * Lecture du pas CALL LIRENT(J,1,IRETOU) IF(IERR.NE.0) GOTO 900 NW=0 N =0 SEGINI MEVOLL JMEVO=MEVOLL IEVTEX=MEVOL1.IEVTEX ITYEVO=MEVOL1.ITYEVO DO 11 KE=1,MEVOL1.IEVOLL(/1) SEGINI WEVOX,WEVOY KEVOL1=MEVOL1.IEVOLL(KE) MLREE1=KEVOL1.IPROGX MLREE2=KEVOL1.IPROGY DO KN=1,MLREE1.PROG(/1),J WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) ENDDO * création évolution résultat SEGINI KEVOLL IEVOLL(**)=KEVOLL NUMEVY=KEVOL1.NUMEVY TYPX ='LISTREEL' TYPY ='LISTREEL' NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY KEVTEX=KEVOL1.KEVTEX NUMEVX=KEVOL1.NUMEVX LPROG=WEVOX(/1) JG=LPROG SEGINI MLREE1 SEGINI MLREE2 IPROGX=MLREE1 IPROGY=MLREE2 DO KN=1,LPROG MLREE1.PROG(KN)=WEVOX(KN) MLREE2.PROG(KN)=WEVOY(KN) ENDDO SEGSUP WEVOX,WEVOY 11 CONTINUE GOTO 777 ************************************************************************ * Options AVANT / APRES [INDI] ['ZERO'] ************************************************************************ 20 CONTINUE CALL LIRMOT(MOINDI,1,IINDI,0) IF(IERR.NE.0) GOTO 900 IF(IINDI.NE.0) THEN CALL LIRENT(KKK,1,IRETOU) IF(IERR.NE.0) GOTO 900 ELSE CALL LIRREE(FLT,1,IRETOU) IF(IERR.NE.0) GOTO 900 ENDIF NW =0 N =0 IZE=0 SEGINI MEVOLL JMEVO=MEVOLL IEVTEX=MEVOL1.IEVTEX ITYEVO=MEVOL1.ITYEVO DO 21 KE=1,MEVOL1.IEVOLL(/1) SEGINI WEVOX,WEVOY KEVOL1=MEVOL1.IEVOLL(KE) MLREE1=KEVOL1.IPROGX MLREE2=KEVOL1.IPROGY C IF(IINDI.EQ.0) THEN * comparaison de la valeur avec le seuil IF(IMOT.EQ.2) THEN DO KN=1,MLREE1.PROG(/1) IF(FLT.GE.MLREE1.PROG(KN)) THEN WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) ENDIF ENDDO ELSEIF(IMOT.EQ.3) THEN DO KN=1,MLREE1.PROG(/1) IF(FLT.LE.MLREE1.PROG(KN)) THEN WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) ENDIF ENDDO ENDIF ELSE * comparaison de l'indice avec le seuil IF(IMOT.EQ.2) THEN DO KN=1,KKK WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) ENDDO ELSEIF(IMOT.EQ.3) THEN DO KN=KKK,MLREE1.PROG(/1) WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) ENDDO ENDIF ENDIF C changement de l'origine des abscisses à zéro ? LPROG=WEVOX(/1) CALL LIRMOT(MOZERO,1,IVAL,0) IF(IERR.NE.0) GOTO 900 IF(IVAL.NE.0) THEN IZE=1 FLT=WEVOX(1) ENDIF * création évolution résultat SEGINI KEVOLL IEVOLL(**)=KEVOLL NUMEVY=KEVOL1.NUMEVY TYPX ='LISTREEL' TYPY ='LISTREEL' NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY KEVTEX=KEVOL1.KEVTEX NUMEVX=KEVOL1.NUMEVX JG=LPROG SEGINI MLREE1 SEGINI MLREE2 IPROGX=MLREE1 IPROGY=MLREE2 IF(IZE.EQ.0) THEN DO KN=1,LPROG MLREE1.PROG(KN)=WEVOX(KN) MLREE2.PROG(KN)=WEVOY(KN) ENDDO ELSE DO KN=1,LPROG MLREE1.PROG(KN)=WEVOX(KN)-FLT MLREE2.PROG(KN)=WEVOY(KN) ENDDO ENDIF SEGSUP WEVOX,WEVOY 21 CONTINUE GOTO 777 ************************************************************************ * Option COMP [INDI] ['ZERO'] ************************************************************************ 30 CONTINUE c lectures CALL LIRMOT(MOINDI,1,IINDI,0) IF(IERR.NE.0) GOTO 900 IF(IINDI.NE.0) THEN CALL LIRENT(KKK1,1,IRETOU) IF(IERR.NE.0) GOTO 900 CALL LIRENT(KKK2,1,IRETOU) IF(IERR.NE.0) GOTO 900 IF(KKK1.GT.KKK2.or.KKK1.le.0.or.KKK2.le.0) THEN INTERR(1)=KKK1 INTERR(2)=KKK2 CALL ERREUR(190) GOTO 900 ENDIF c write(ioimp,*) 'KKK1,KKK2=',KKK1,KKK2 ELSE CALL LIRREE(FLT1,1,IRETOU) IF(IERR.NE.0) GOTO 900 CALL LIRREE(FLT2,1,IRETOU) IF(IERR.NE.0) GOTO 900 IF(FLT1.GT.FLT2) THEN REAERR(1)=FLT1 REAERR(2)=FLT2 CALL ERREUR(191) GOTO 900 ENDIF c write(ioimp,*) 'FLT1,FLT2=',FLT1,FLT2 ENDIF c travail NW =0 N =0 IZE=0 SEGINI MEVOLL JMEVO=MEVOLL IEVTEX=MEVOL1.IEVTEX ITYEVO=MEVOL1.ITYEVO DO 31 KE=1,MEVOL1.IEVOLL(/1) SEGINI WEVOX,WEVOY KEVOL1=MEVOL1.IEVOLL(KE) MLREE1=KEVOL1.IPROGX MLREE2=KEVOL1.IPROGY C IF(IINDI.EQ.0) THEN * comparaison de la valeur avec le seuil DO 32 KN=1,MLREE1.PROG(/1) IF(MLREE1.PROG(KN).LT.FLT1) GOTO 32 IF(MLREE1.PROG(KN).GT.FLT2) GOTO 32 WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) 32 CONTINUE ELSE * comparaison de l'indice avec le seuil if(KKK2.gt.MLREE1.PROG(/1)) then INTERR(1)=KKK2 CALL ERREUR(36) GOTO 900 endif DO KN=KKK1,KKK2 WEVOX(**)=MLREE1.PROG(KN) WEVOY(**)=MLREE2.PROG(KN) ENDDO ENDIF C changement de l'origine des abscisses à zéro ? LPROG=WEVOX(/1) CALL LIRMOT(MOZERO,1,IVAL,0) IF(IERR.NE.0) GOTO 900 IF(IVAL.NE.0) THEN IZE=1 FLT=WEVOX(1) ENDIF * création évolution résultat SEGINI KEVOLL IEVOLL(**)=KEVOLL NUMEVY=KEVOL1.NUMEVY TYPX ='LISTREEL' TYPY ='LISTREEL' NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY KEVTEX=KEVOL1.KEVTEX NUMEVX=KEVOL1.NUMEVX JG=LPROG SEGINI MLREE1 SEGINI MLREE2 IPROGX=MLREE1 IPROGY=MLREE2 IF(IZE.EQ.0) THEN DO KN=1,LPROG MLREE1.PROG(KN)=WEVOX(KN) MLREE2.PROG(KN)=WEVOY(KN) ENDDO ELSE DO KN=1,LPROG MLREE1.PROG(KN)=WEVOX(KN)-FLT MLREE2.PROG(KN)=WEVOY(KN) ENDDO ENDIF SEGSUP WEVOX,WEVOY 31 CONTINUE GOTO 777 ************************************************************************ * Ecriture du resultat ************************************************************************ 777 CONTINUE CALL ACTOBJ('EVOLUTIO',JMEVO,1) CALL ECROBJ('EVOLUTIO',JMEVO) ************************************************************************ * si erreur 5, on quitte proprement ... ************************************************************************ 900 CONTINUE RETURN END