Sources Esope | Cast3M

fdt
C FDT       SOURCE    BP208322  16/11/18    21:17:04     9177           
      SUBROUTINE FDT
C
C**************************************************************
C
C   SUBROUTINE ASSOCIE A L OPERATEUR FDT
C
C   26/06/86 AUTEUR D. BROCHARD (VIBR POSTE 6994)
C
C     CREATION D UN OBJET EVOLUTION A PARTIR D UN PROG (TIROIR)
C
C     S Y N T A X E
C     -------------
C
C      EVOL = FDT MOT ('CONS'  DT  FTI           )
C                     (                          )
C                     ('NOCO'  ( 'COUP'  TIFTI ) )
C                     (        (               ) )
C                     (        ( TFT           ) )
C                     (                          )
C                     ( PROG1  PROG2             )
C
C    MOT   TYPE DE DONNEE (ACCE,DEPL,ETC...)
C    CONS  SIGNAL A PAS CONSTANT
C           DT  OBJET FLOTTANT PAS DE TEMPS
C           FTI OBJET LISTREEL VALEUR DU SIGNAL
C    NOCO  SIGNAL A PAS NON CONSTANT
C           COUP MOT INDI QUANT QUE LE SIGNAL EST RENTRE
C                SOUS LA FORME DE COUPLES TIFTI(OBJET LISTREEL)
C           TFT  OBJET LISTREEL CONTENANT T(I),I=1,N PUIS
C                F(TI),I=1,N
C    PROG1,PROG2 OBJETS DE TYPE LISTREEL . L UN DES DEUX CONTIENT
C                UN SEUL NOMBRE:DT
C                SI DT > 0 SIGNAL A PAS CONSTANT DONT LES VALEURS
C                          SONT DANS PROG2
C                SI DT &lt; 0 SIGNAL A PAS NON CONSTANT VALEURS DANS
C                          PROG2 : T(I),I=1,N PUIS F(TI),I=1,N
C
C
C*******************************************************************
C
C
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMEVOLL
-INC SMLREEL
      CHARACTER*72 TI
      CHARACTER*4 MOT1,MOT2,MOT3
      CHARACTER*4 NOMC(2)
C
      DATA NOMC/'CONS','NOCO'/
C
C
      LNOMC=2
C
      CALL LIRCHA(MOT1,1,IRETOU)
      CALL LIRCHA(MOT2,0,IRETOU)
C
C
      IF(IRETOU.EQ.0) GOTO 300
C
      CALL PLACE(NOMC,LNOMC,IMOT,MOT2)
C
C
      IF(IMOT.EQ.0) GOTO 1000
      GOTO (101,102),IMOT
C
C
101   CONTINUE
C
C     PAS CONSTANT DT FTI
C
      CALL LIRREE(DFLOT,1,IRETOU)
      DT=DFLOT
      CALL LIROBJ('LISTREEL',IPO,1,IRETOU)
      MLREEL=IPO
C
C
350   CONTINUE
      SEGACT MLREEL
      LT=MLREEL.PROG(/1)
      JG=LT
      SEGINI MLREE1
      T=0.D0
      DO 110 I=1,LT
      MLREE1.PROG(I)=T
      T=T+DT
110   CONTINUE
C
C
C
      IPX=MLREE1
      IPY=MLREEL
      SEGDES MLREEL,MLREE1
      GOTO 200
C
C
102   CONTINUE
C
C     PAS NON CONSTANT
C
      CALL LIRCHA(MOT3,0,IRETOU)
C
      IF(IRETOU.EQ.0) GOTO 150
C
C     ON A LU COUPLE LE PROG CONTIENT TI,FTI
C
      CALL LIROBJ('LISTREEL',IPO,1,IRETOU)
      MLREEL=IPO
      SEGACT MLREEL
      LTFT=PROG(/1)
      LT=LTFT/2
      JG=LT
      SEGINI MLREE1
      SEGINI MLREE2
C
      DO 103 I=1,LT
      I1=2*I-1
      I2=2*I
      MLREE1.PROG(I)=PROG(I1)
      MLREE2.PROG(I)=PROG(I2)
103   CONTINUE
C
C
160   CONTINUE
      LT1=MLREE1.PROG(/1)-1
      DO 104 I=1,LT1
      IF(MLREE1.PROG(I).GT.MLREE1.PROG(I+1)) GOTO 105
104   CONTINUE
      IPX=MLREE1
      IPY=MLREE2
      SEGDES MLREE1,MLREE2,MLREEL
      GOTO 200
C
C
105   CONTINUE
C
C     ERREUR
C
      CALL ERREUR(285)
      RETURN
C
C
150   CONTINUE
C
C     ON LIT UN PROG CONTENANT TI,I=1,N PUIS FTI,I=1,N
C
      CALL LIROBJ('LISTREEL',IPO,1,IRETOU)
      MLREEL=IPO
360   CONTINUE
      SEGACT MLREEL
      LTFT=PROG(/1)
      LT=LTFT/2
      JG=LT
      SEGINI MLREE1
      SEGINI MLREE2
      DO 151 I=1,LT
      I1=I+LT
      MLREE1.PROG(I)=PROG(I)
      MLREE2.PROG(I)=PROG(I1)
151   CONTINUE
C
C
      GOTO 160
C
C
300   CONTINUE
C
C     TIROIR ON FOURNIT DEUX PROG   UN DES DEUX CONTIENT DT
C
      CALL LIROBJ('LISTREEL',IPA,1,IRETOU)
      CALL LIROBJ('LISTREEL',IPB,1,IRETOU)
      MLREE1=IPA
      MLREE2=IPB
      SEGACT MLREE1
      IF(MLREE1.PROG(/1).NE.1) GOTO 301
310   DT=MLREE1.PROG(1)
      SEGDES MLREE1
      MLREEL=MLREE2
      IF(DT.NE.0) GOTO 350
      GOTO 360
C
C
301   CONTINUE
      SEGDES MLREE1
      MLREE1=IPB
      MLREE2=IPA
      SEGACT MLREE1
      IF(MLREE1.PROG(/1).NE.1) GOTO 302
      GOTO 310
C
C
302   CALL ERREUR(294)
      RETURN
200   CONTINUE
C
C     INITIALISATION DE L OBJET EVOLUTION
C
      N=1
      SEGINI MEVOLL
      SEGINI KEVOLL
      TYPX='LISTREEL'
      TYPY='LISTREEL'
      IPROGX=IPX
      IPROGY=IPY
      NOMEVX='TEMPS   SEC'
      NOMEVY=MOT1
C
      ITYEVO='REEL'
      NUMEVX=IDCOUL
      NUMEVY='REEL'
C
      SEGDES KEVOLL
C
      TI(1:72)=TITREE
      IEVTEX=TI
      IEVOLL(1)=KEVOLL
C
      SEGDES MEVOLL
C
      CALL ECROBJ('EVOLUTIO',MEVOLL)
      RETURN
C
1000  CONTINUE
       moterr(1:4)=mot2
      call erreur(7)
      CALL GINT2
      RETURN
C
      END