Télécharger la plaquette Cast3M


fr en

Télécharger interp.eso

Retour à la liste

Numérotation des lignes : 

interp

  1. C INTERP    SOURCE    CB215821  23/12/07    21:15:04     11805          
  2.       SUBROUTINE INTERP
  3. C
  4. C=======================================================================
  5. C
  6. C     Opérateur IPOL
  7. C
  8. C     SYNTAXE : voir notice
  9. C
  10. C=======================================================================
  11. C
  12. C    Remarques
  13. C
  14. C       Les listes LISTREE1 et LISTREE2 doivent se correspondre
  15. C
  16. C       L'évolution EVOL1 doit être élémentaire
  17. C
  18. C       ATTENTION : la liste des abscisses donnéee est supposée monotone
  19. C
  20. C=======================================================================
  21. C
  22. C    Auteur   :
  23. C    Création :
  24. C    Modifications : voir fiches d'anomalie
  25. C
  26. C=======================================================================
  27.  
  28.       IMPLICIT INTEGER(I-N)
  29.       IMPLICIT    REAL*8(A-H,O-Z)
  30.       PARAMETER (NCLE=2)
  31.       CHARACTER*8 TYPE1,TYPE2,TYPEI,TYPO1,TYPO2,TYPOBJ
  32.       CHARACTER*8 CHARIN,CHARRE
  33.       LOGICAL     LOGIN,LOGRE
  34.       CHARACTER*4 MCLE(NCLE)
  35.       DATA MCLE/'TOUS','SPLI'/
  36.       CHARACTER*4 CDER(2)
  37.       DATA CDER/'DGAU','DDRO'/
  38.       LOGICAL LCDER(2)
  39.       REAL*8 XCDER(2)
  40.  
  41. -INC SMLREEL
  42.       POINTEUR MLREE4.MLREEL,MLDERS.MLREEL,MLDER.MLREEL
  43. -INC CCREEL
  44. -INC SMCHPOI
  45. -INC SMELEME
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC SMCHAML
  50. -INC SMTABLE
  51. -INC SMEVOLL
  52.       SEGMENT TABR
  53.          REAL*8   TEMA(LOR)
  54.       ENDSEGMENT
  55.  
  56.       KEVOLL = 0
  57.  
  58. *     syntaxe 3 ?
  59.       CALL LIROBJ('NUAGE   ',INUA,0,IRETOU)
  60.       IF (IERR.NE.0) RETURN
  61.       IF(IRETOU.EQ.1) THEN
  62.         CALL ACTOBJ('NUAGE   ',INUA,1)
  63.         CALL IPLNU1(INUA)
  64.         RETURN
  65.       ENDIF
  66. *     syntaxe 2 ?
  67.       CALL LIROBJ('TABLE',IPOT,0,IRETOU)
  68.       IF (IERR.NE.0) RETURN
  69.       IF(IRETOU.EQ.1) THEN
  70.         CALL  LIRREE(TEMPS,1,IRETOU)
  71.         IF(IERR.NE.0) RETURN
  72.         GOTO 50
  73.       ENDIF
  74.  
  75. *     syntaxe 1 (INDIC=1 à 4)
  76.       CALL LIROBJ('CHPOINT ',MTEMP,0,IRETOU)
  77.       IF (IERR.NE.0) RETURN
  78.       IF(IRETOU.EQ.1) THEN
  79.         CALL ACTOBJ('CHPOINT ',MTEMP,1)
  80.         IF (IERR.NE.0) RETURN
  81.         ICHPO1 = MTEMP
  82. C
  83. C       Interpolation d'un point d'abscisse curviligne FLOT1
  84.         CALL LIRREE(FLOT1,0,IRETOU)
  85.         IF (IERR.NE.0) RETURN
  86.         IF (IRETOU.EQ.1) THEN
  87.           CALL IPLCUR(ICHPO1,FLOT1,IPOIN1)
  88.           IF (IERR.NE.0) RETURN
  89.           IF (IPOIN1.EQ.0) CALL ERREUR(251)
  90.           CALL ECROBJ('POINT   ',IPOIN1)
  91.           RETURN
  92.         ELSE
  94.         ENDIF
  95.       ELSE
  96.         CALL LIRREE(TEMPS,0,IRETOU)
  97.         IF (IERR.NE.0) RETURN
  98.         IF(IRETOU.EQ.1) THEN
  100.         ELSE
  101.           CALL LIROBJ('MCHAML ',IPO1,0,IRETOU)
  102.           IF (IERR.NE.0) RETURN
  103.           IF(IRETOU.EQ.1) THEN
  104.             CALL ACTOBJ('MCHAML ',IPO1,1)
  105.             IF (IERR.NE.0) RETURN
  107.           ELSE
  108.             CALL LIROBJ('LISTREEL',MLIST,0,IRETOU)
  109.             IF (IERR.NE.0) RETURN
  110.             IF(IRETOU.EQ.1) THEN
  111.               CALL ACTOBJ('LISTREEL',MLIST,1)
  112.               IF (IERR.NE.0) RETURN
  113.             ELSE
  114. *             Pas d opérande correcte trouvée
  115.               CALL QUETYP(MOTERR(1:8),0,IRETOU)
  116.               IF (IERR.NE.0) RETURN
  117.               IF(IRETOU.NE.0) THEN
  118. *               On ne veut pas d'objet de type %m1:8
  119.                 CALL ERREUR(39)
  120.               ELSE
  121. *               Cet opérateur a encore besoin d'un opérande
  122.                 CALL ERREUR(533)
  123.               ENDIF
  124.               RETURN
  125.             ENDIF
  127.           ENDIF
  128.         ENDIF
  129.       ENDIF
  130.  
  131. *     Lecture de la fonction à interpoler
  132.       CALL LIROBJ('EVOLUTIO',IEVL,0,IRETOU)
  133.       IF (IERR.NE.0) RETURN
  134.       IF(IRETOU.EQ.1) THEN
  135.         CALL ACTOBJ('EVOLUTIO',IEVL,1)
  136.         IF (IERR.NE.0) RETURN
  137.         MEVOLL=IEVL
  138. *       Vérification que l'évolution est élémentaire
  139.         IF (IEVOLL(/1).NE.1) THEN
  140. *         Opération interdite sur un objet complexe
  141.           CALL ERREUR(25)
  142.           RETURN
  143.         ENDIF
  144.         KEVOLL=IEVOLL(1)
  145. *       de type scalaire
  146.         IF (ITYEVO.NE.'REEL') THEN
  147. *         Opération interdite sur un objet complexe
  148.           CALL ERREUR(25)
  149.           RETURN
  150.         ENDIF
  151. *       peuplée de flottants
  152.         IF ((TYPX.NE.'LISTREEL').OR.(TYPY.NE.'LISTREEL')) THEN
  153. *         Certaines courbes ne sont pas du bon type
  154.           CALL ERREUR(871)
  155.           RETURN
  156.         ENDIF
  157.         KTE=IPROGX
  158.         KFT=IPROGY
  159.       ELSE
  160.         CALL LIROBJ('LISTREEL',KTE,1,IRETOU)
  161.         IF(IERR.NE.0) RETURN
  162.         CALL LIROBJ('LISTREEL',KFT,1,IRETOU)
  163.         IF(IERR.NE.0) RETURN
  164.       ENDIF
  165.  
  166. *     Longueur des listes décrivant la fonction
  167.       MLREE1=KTE
  168.       MLREE2=KFT
  169.       SEGACT MLREE1,MLREE2
  170.       IF(MLREE1.PROG(/1).NE.MLREE2.PROG(/1)) THEN
  171. *       Les suites n ont pas la même longueur
  172.         CALL ERREUR(212)
  173.         RETURN
  174.       ENDIF
  175.       LON=MLREE1.PROG(/1)
  176.  
  177. C     erreur 897 2 :
  178. C     "La dimension des LISTREEL doit etre plus grande que 1"
  179.       IF (LON.LT.1) THEN
  180.          CALL ERREUR(897)
  181.          RETURN
  182.       ENDIF
  183.  
  184. c---- Lecture des options :
  185. C     ITOUS : option TOUS
  186. C     ISPLI : option SPLI
  187. C     IHORS : comportement en dehors de l'intervalle de def. des donnees
  188. C     IHORS = 0 : option ERREur
  189. C     IHORS = 1 : option BORNE (valeur aux bornes)
  190. C     IHORS = 2 : option EXTRapolation lineaire
  191.       ITOUS = 0
  192.       ISPLI = 0
  193.       IHORS = 1
  194.  2    CALL LIRMOT(MCLE,NCLE,ICLE,0)
  195.       IF (IERR.NE.0) RETURN
  196.       IF (ICLE.EQ.1) ITOUS = 1
  197.       IF (ICLE.EQ.2) ISPLI = 1
  198. C     IF (ICLE.EQ.3) IHORS = 1
  199. C     IF (ICLE.EQ.4) IHORS = 2
  200. C     IF (ICLE.EQ.5) IHORS = 0
  201.       IF (ICLE.NE.0) GOTO 2
  202.  
  203. C     write(6,*) 'ITOUS =',ITOUS
  204. C     write(6,*) 'ISPLI =',ISPLI
  205. C     write(6,*) 'IHORS =',IHORS
  206.  
  207. C     Petite verification compatibilite options
  208.       IF (ITOUS.EQ.1.AND.ISPLI.EQ.1) THEN
  209.         CALL ERREUR(34)
  210.         RETURN
  211.       ENDIF
  212. C     Option "TOUS" : pas d'extrapolation possible
  213. C     IF (ITOUS.EQ.1.AND.IHORS.EQ.2) THEN
  214. C       CALL ERREUR(34)
  215. C       RETURN
  216. C     ENDIF
  217.  
  218. C     Verif. donnees option 'TOUS'
  219.       IF(ITOUS.EQ.1) THEN
  220.         IF(INDIC.NE.1) THEN
  221. c         Option %M1:8 incompatible avec les donnees
  222.           MOTERR(1:8)='TOUS'
  223.           CALL ERREUR(803)
  224. c         On desire lire un nombre
  225.           CALL ERREUR(15)
  226.           RETURN
  227.         ENDIF
  228.         ISENS=0
  229. c         GOTO 1
  230. c       On va directement en 10 car SPLINE incompatible avec TOUS
  231.         GOTO 10
  232.       ENDIF
  233.  
  234.       TDEB=MLREE1.PROG(1)
  235.       TFIN=MLREE1.PROG(LON)
  236. *     Les x sont-ils croissants ou décroissants ?
  237.       IF (TFIN.GE.TDEB) THEN
  238.          ISENS=0
  239.       ELSE
  240. c        si decroissant, on retourne la liste
  241.          ISENS=1
  242.          JG=LON
  243.          SEGINI,MLREE3,MLREE4
  244.          DO ILON=1,LON
  245.             MLREE3.PROG(ILON)=MLREE1.PROG(LON-ILON+1)
  246.             MLREE4.PROG(ILON)=MLREE2.PROG(LON-ILON+1)
  247.          ENDDO
  248.          MLREE1=MLREE3
  249.          MLREE2=MLREE4
  250.          TDEB=MLREE1.PROG(1)
  251.          TFIN=MLREE1.PROG(LON)
  252.       ENDIF
  253. C
  254. C Vérification que la liste est ordonnée
  255. C
  256.        TPRE=TDEB
  257.        DO ILON=2,LON
  258.           TCOU=MLREE1.PROG(ILON)
  259.           IF (TCOU.LT.TPRE) GOTO 6661
  260.           TPRE=TCOU
  261.        ENDDO
  262. c       ENDIF
  263.       GOTO 1
  264.  6661 CONTINUE
  265. C     erreur 249 2 : "La suite de reels doit etre croissante"
  266. cbp : en realite elle doit etre monotone (decroissante possible)
  267.       CALL ERREUR(249)
  268.       RETURN
  269.  
  270.  1    CONTINUE
  271. *
  272. * Option SPLINE :
  273. *
  274.       IF (ISPLI.EQ.1) THEN
  275.          LCDER(1)=.FALSE.
  276.          LCDER(2)=.FALSE.
  277. *  Lecture des mots clés et valeurs associées
  278. *  On lit les valeurs des dérivées premières à gauche et à droite
  279. *  Si elles ne sont pas données, c'est la condition à la limite
  280. *  naturelle qui s'applique
  281.  77      CONTINUE
  282.          CALL LIRMOT(CDER,2,ICDER,0)
  283.          IF (IERR.NE.0) RETURN
  284.          IF (ICDER.GT.0) THEN
  285.             LCDER(ICDER)=.TRUE.
  286.             CALL LIRREE(XCDER(ICDER),1,IRETOU)
  287.             IF(IERR.NE.0) RETURN
  288.             GOTO 77
  289.          ENDIF
  290.          JG=LON
  291.          SEGINI MLDERS
  292.          SEGINI MLDER
  293.          IF (LCDER(1)) THEN
  294. * Cas où on prescrit la dérivée première à gauche
  295.             MLDERS.PROG(1)=-0.5D0
  296.             DX=MLREE1.PROG(2)-MLREE1.PROG(1)
  297.             DY=MLREE2.PROG(2)-MLREE2.PROG(1)
  298.             MLDER.PROG(1)=(3.D0/DX)*((DY/DX)-XCDER(1))
  299.          ELSE
  300. * Condition de bord naturelle (dérivée seconde nulle)
  301.             MLDERS.PROG(1)=XZERO
  302.             MLDER.PROG(1)=XZERO
  303.          ENDIF
  304.          DO ILON=2,LON-1
  305.             XIM=MLREE1.PROG(ILON-1)
  306.             XI=MLREE1.PROG(ILON)
  307.             XIP=MLREE1.PROG(ILON+1)
  308.             YIM=MLREE2.PROG(ILON-1)
  309.             YI=MLREE2.PROG(ILON)
  310.             YIP=MLREE2.PROG(ILON+1)
  311.             DXIM=XI-XIM
  312.             DXI2=XIP-XIM
  313.             DXIP=XIP-XI
  314.             XRAP=DXIM/DXI2
  315.             XP=XRAP*MLDERS.PROG(ILON-1)+2.D0
  316.             MLDERS.PROG(ILON)=(XRAP-1.D0)/XP
  317.             DYIP=YIP-YI
  318.             DYIM=YI-YIM
  319.             MLDER.PROG(ILON)=(6.D0*(DYIP/DXIP-DYIM/DXIM)/DXI2-XRAP
  320.      $           *MLDER.PROG(ILON-1))/XP
  321.          ENDDO
  322.          IF (LCDER(2)) THEN
  323.             XQN=0.5D0
  324.             DX=MLREE1.PROG(LON)-MLREE1.PROG(LON-1)
  325.             DY=MLREE2.PROG(LON)-MLREE2.PROG(LON-1)
  326.             XUN=(3.D0/DX)*(XCDER(2)-(DY/DX))
  327.          ELSE
  328. * Condition de bord naturelle (dérivée seconde nulle)
  329.             XQN=0.D0
  330.             XUN=0.D0
  331.          ENDIF
  332.          MLDERS.PROG(LON)=(XUN-XQN*MLDER.PROG(LON-1))/
  333.      $        (XQN*MLDERS.PROG(LON-1)+1.D0)
  334.          DO ILON=LON-1,1,-1
  335.             MLDERS.PROG(ILON)=MLDERS.PROG(ILON)*MLDERS.PROG(ILON+1)
  336.      $           +MLDER.PROG(ILON)
  337.          ENDDO
  338.          SEGSUP MLDER
  339. c          write(*,*) 'MLDERS=',(MLDERS.PROG(iou),iou=1,LON)
  340.       ELSE
  341.          MLDERS=0
  342.       ENDIF
  343. *
  344. *     Répartition suivant le type de l'objet fourni
  345. *
  346. C     write(6,*) 'INDIC =',INDIC
  347.       GOTO (10,20,30,40) INDIC
  348.  
  349. ******************   T0  FLOTTANT  *******************************
  350.  
  351. 10    CONTINUE
  352.       IF(ITOUS.EQ.1) THEN
  353.         CALL INTER4(TEMPS,MLREE1,MLREE2,IHORS,IRET)
  354.         IF (IERR.NE.0) RETURN
  355.         IF (IRET.NE.0) THEN
  356.           CALL ACTOBJ('LISTREEL',IRET,1)
  357.           IF (IERR.NE.0) RETURN
  358.           CALL ECROBJ('LISTREEL',IRET)
  359.           IF (IERR.NE.0) RETURN
  360.         ENDIF
  361.       ELSE
  362.         CALL INTER5(TEMPS,MLREE1,MLREE2,FT0,
  363.      &              ISPLI,MLDERS,IHORS,IRET)
  364.         IF (IERR.NE.0) RETURN
  365.         IF (IRET.EQ.1) CALL ECRREE(FT0)
  366.         IF (IERR.NE.0) RETURN
  367.       ENDIF
  368.       GOTO 999
  369.  
  370. *********************   T0  CHPOINT  *****************************
  371.  
  372. 20    CONTINUE
  373.       MCHPO1=MTEMP
  374.       CALL NBCOMP(MCHPO1,'CHPOINT ',NB_Cmp)
  375.       IF(NB_Cmp .NE. 1)THEN
  376.         CALL ERREUR(180)
  377.         RETURN
  378.       ENDIF
  379.       SEGINI,MCHPOI=MCHPO1
  380.       MFT0=MCHPOI
  381.       NS=IPCHP(/1)
  382.       DO 21 IA=1,NS
  383.         MSOUP1=IPCHP(IA)
  384.         SEGINI,MSOUPO=MSOUP1
  385.         NC=NOHARM(/1)
  386.         IF(KEVOLL .NE. 0)THEN
  387.           MSOUPO.NOCOMP(1)=KEVOLL.NOMEVY
  388.         ELSE
  389.           MSOUPO.NOCOMP(1)='SCAL'
  390.         ENDIF
  391.         IPCHP(IA)=MSOUPO
  392. C        IPT1=IGEOC
  393. C        SEGINI,IPT2=IPT1
  394. C        IGEOC=IPT2
  395.         MPOVA1=IPOVAL
  396.         SEGINI,MPOVAL=MPOVA1
  397.         IPOVAL=MPOVAL
  398.         N=VPOCHA(/1)
  399.         DO IB=1,N
  400.           DO IC=1,NC
  401.             TEMPS=VPOCHA(IB,IC)
  402.             CALL INTER5(TEMPS,MLREE1,MLREE2,FT0,
  403.      &                  ISPLI,MLDERS,IHORS,IRET)
  404.             IF (IERR.NE.0) RETURN
  405.             IF (IRET.EQ.0) THEN
  406.               SEGSUP MCHPOI,MSOUPO,MPOVAL
  407.               GOTO 999
  408.             ENDIF
  409.             VPOCHA(IB,IC)=FT0
  410.           ENDDO
  411.         ENDDO
  412. 21    CONTINUE
  413.       CALL ACTOBJ('CHPOINT ',MFT0,1)
  414.       IF (IERR.NE.0) RETURN
  415.       CALL ECROBJ('CHPOINT ',MFT0)
  416.       IF (IERR.NE.0) RETURN
  417.       GOTO 999
  418.  
  419. *******************   T0 EST UN LISTREEL  ***********************
  420.  
  421. 30    CONTINUE
  422.       MLREE3=MLIST
  423.       SEGACT MLREE3
  424.       LONG=MLREE3.PROG(/1)
  425.       JG=LONG
  426.       SEGINI MLREEL
  427.       MSOL=MLREEL
  428.       DO 31 ILOOP=1,LONG
  429.         TEMPS=MLREE3.PROG(ILOOP)
  430.         CALL INTER5(TEMPS,MLREE1,MLREE2,FTO,
  431.      &              ISPLI,MLDERS,IHORS,IRET)
  432.         IF (IERR.NE.0) RETURN
  433.         IF(IRET.EQ.0) GOTO 999
  434.         PROG(ILOOP)=FTO
  435. 31    CONTINUE
  436.       CALL ACTOBJ('LISTREEL',MSOL,1)
  437.       IF (IERR.NE.0) RETURN
  438.       CALL ECROBJ('LISTREEL',MSOL)
  439.       IF (IERR.NE.0) RETURN
  440.       GOTO 999
  441.  
  442. ***********************   T0  MCHAML   ***************************
  443.  
  444. 40    CONTINUE
  445.       IRET=0
  446.       MCHEL1=IPO1
  447.  
  448.       CALL NBCOMP(MCHEL1,'MCHAML  ',NB_Cmp)
  449.       IF(NB_Cmp .NE. 1)THEN
  450.         CALL ERREUR(320)
  451.         RETURN
  452.       ENDIF
  453.       SEGINI,MCHELM=MCHEL1
  454.       IRET=MCHELM
  455.       NSOUS=IMACHE(/1)
  456.       DO 72 IA=1,NSOUS
  457.         MCHAM1=ICHAML(IA)
  458.         SEGINI,MCHAML=MCHAM1
  459.         IF(KEVOLL .NE. 0)THEN
  460.           MCHAML.NOMCHE(1)=KEVOLL.NOMEVY
  461.         ELSE
  462.           MCHAML.NOMCHE(1)='SCAL'
  463.         ENDIF
  464.         ICHAML(IA)=MCHAML
  465.         DO 75 ICOMP=1,IELVAL(/1)
  466.           MELVA1 = IELVAL(ICOMP)
  467.           SEGINI,MELVAL=MELVA1
  468.           IELVAL(ICOMP) = MELVAL
  469.           SEGACT MELVA1
  470.           IF (TYPCHE(ICOMP).NE.'REAL*8') GOTO 75
  471.           N1PTEL=VELCHE(/1)
  472.           N1EL  =VELCHE(/2)
  473.           N2PTEL=0
  474.           N2EL  =0
  475.           DO IB=1,N1PTEL
  476.             DO ID=1,N1EL
  477.               TEMPS=MELVA1.VELCHE(IB,ID)
  478.               CALL INTER5(TEMPS,MLREE1,MLREE2,FT0,
  479.      &                    ISPLI,MLDERS,IHORS,IREE)
  480.               IF (IERR.NE.0) RETURN
  481.               IF (IREE.EQ.0) THEN
  482.                 SEGSUP MCHELM,MCHAML,MELVAL
  483.                 GOTO 999
  484.               ENDIF
  485.               VELCHE(IB,ID)=FT0
  486.             ENDDO
  487.           ENDDO
  488. 75      CONTINUE
  489. 72    CONTINUE
  490.       CALL ACTOBJ('MCHAML  ',IRET,1)
  491.       IF (IERR.NE.0) RETURN
  492.       CALL ECROBJ('MCHAML  ',IRET)
  493.       IF (IERR.NE.0) RETURN
  494.       GOTO 999
  495.  
  496. ************************  OBJET1  TABLE  ******************************
  497.  
  498. 50    CONTINUE
  499.       MTABLE = IPOT
  500.       SEGACT MTABLE
  501.       LO = MLOTAB
  502.  
  503. *--   Vérification du format de la table
  504.       IF (LO.LE.2) THEN
  505. *       La table n'a pas le format désiré
  506.         CALL ERREUR(647)
  507.         RETURN
  508.       ENDIF
  509.  
  510.       LOR = LO
  511.       SEGINI TABR
  512.  
  513. *--   Vérification du sous-type de la table
  514. *     IMOT est son indice dans la table
  515.       IOK = 0
  516.       DO 55 I=1,LO
  517.         TYPE1 = MTABTI(I)
  518.         IF(TYPE1.EQ.'MOT     ') THEN
  519.           CHARIN = 'SOUSTYPE'
  520.           TYPOBJ = ' '
  521.           CALL ACCTAB(MTABLE,TYPE1,IVALIN,XVALIN,CHARIN,LOGIN,
  522.      $               IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE)
  523.           IF (IERR.NE.0) RETURN
  524.           segact mtable
  525.           IF(CHARIN.EQ.'SOUSTYPE') THEN
  526.             IF(CHARRE.EQ.'RESULTAT') THEN
  527.               IOK  = 1
  528.               IMOT = I
  529.             ENDIF
  530.           ENDIF
  531.         ENDIF
  532. 55    CONTINUE
  533.  
  534.       IF(IOK.EQ.0) THEN
  535. *       Le sous-type de la table est incorrect
  536.         CALL ERREUR(648)
  537.         SEGSUP TABR
  538.         RETURN
  539.       ENDIF
  540.  
  541. *--   Vérification qu'on a bien des flottants en indice
  542. *     en dehors du sous-type
  543.       J = 0
  544.       DO 56 I=1,LO
  545.         IF (IMOT.EQ.I) GOTO 56
  546.         J=J+1
  547.         TYPEI = MTABTI(I)
  548.  
  549.         IF (TYPEI.NE.'FLOTTANT') THEN
  550. *         La table n'a pas le format desire
  551.           CALL ERREUR(647)
  552.           SEGSUP TABR
  553.           RETURN
  554.         ENDIF
  555.  
  556.         TEMA(J) = RMTABI(I)
  557. 56    CONTINUE
  558.  
  559. *--   Vérification de l'ordonnancement des indices
  560.       DO 57 I=1,LOR-2
  561.         TEM1 = TEMA(I)
  562.         TEM2 = TEMA(I+1)
  563.  
  564.         IF(TEM1.GT.TEM2) THEN
  565. *         la liste des indices n'est pas ordonnee
  566.           CALL ERREUR(211)
  567.           SEGSUP TABR
  568.           RETURN
  569.         ENDIF
  570.  
  571. 57    CONTINUE
  572.  
  573.       IF(IMOT.EQ.1) THEN
  574.         TEM1   = RMTABI(2)
  575.         TYPO1  = MTABTV(2)
  576.         IVALO1 = MTABIV(2)
  577.         NDEB   = 3
  578.       ENDIF
  579.       IF(IMOT.EQ.2) THEN
  580.         TEM1   = RMTABI(1)
  581.         TYPO1  = MTABTV(1)
  582.         IVALO1 = MTABIV(1)
  583.         NDEB   = 3
  584.       ENDIF
  585.       IF(IMOT.GE.3) THEN
  586.         TEM1   = RMTABI(1)
  587.         TYPO1  = MTABTV(1)
  588.         IVALO1 = MTABIV(1)
  589.         NDEB   = 2
  590.       ENDIF
  591.  
  592.       DO 58 I=NDEB,LOR
  593.         IF(IMOT.EQ.I) GOTO 58
  594.         TEM2   = RMTABI(I)
  595.         TYPO2  = MTABTV(I)
  596.         IVALO2 = MTABIV(I)
  597.         IF((TEM1.LE.TEMPS).AND.(TEMPS.LE.TEM2)) THEN
  598.           DTEM = (TEMPS-TEM1)/(TEM2-TEM1)
  599.           IF(TYPO1.EQ.'CHPOINT ') THEN
  600.             IF(TYPO2.EQ.'CHPOINT ') THEN
  601.               CALL ACTOBJ('CHPOINT ',IVALO2,1)
  602.               IF (IERR.NE.0) RETURN
  603.               CALL ACTOBJ('CHPOINT ',IVALO1,1)
  604.               IF (IERR.NE.0) RETURN
  605.               CALL ECROBJ('CHPOINT ',IVALO2)
  606.               IF (IERR.NE.0) RETURN
  607.               CALL ECROBJ('CHPOINT ',IVALO1)
  608.               IF (IERR.NE.0) RETURN
  609.             ELSE
  610.               CALL ERREUR(647)
  611.               SEGSUP TABR
  612.               RETURN
  613.             ENDIF
  614.           ENDIF
  615.           IF(TYPO1.EQ.'MCHAML  ') THEN
  616.             IF(TYPO2.EQ.'MCHAML  ') THEN
  617.               CALL ACTOBJ('MCHAML  ',IVALO2,1)
  618.               IF (IERR.NE.0) RETURN
  619.               CALL ACTOBJ('MCHAML  ',IVALO1,1)
  620.               IF (IERR.NE.0) RETURN
  621.               CALL ECROBJ('MCHAML  ',IVALO2)
  622.               IF (IERR.NE.0) RETURN
  623.               CALL ECROBJ('MCHAML  ',IVALO1)
  624.               IF (IERR.NE.0) RETURN
  625.             ELSE
  626.               CALL ERREUR(647)
  627.               SEGSUP TABR
  628.               RETURN
  629.             ENDIF
  630.           ENDIF
  631.           CALL ECRREE(DTEM)
  632.           IF (IERR.NE.0) RETURN
  633.           CALL ECRREE(1.D0-DTEM)
  634.           IF (IERR.NE.0) RETURN
  635.           CALL COLI
  636.           IF (IERR.NE.0) RETURN
  637.           SEGSUP TABR
  638.           GOTO 500
  639.         ENDIF
  640.         TEM1   = TEM2
  641.         TYPO1  = TYPO2
  642.         IVALO1 = IVALO2
  643. 58    CONTINUE
  644.  
  645. *     Le temps est en dehors des limites de la table
  646.       CALL ERREUR(210)
  647.       SEGSUP TABR
  648.       GOTO 500
  649.  
  650. 999   CONTINUE
  651.       IF (ISENS.GT.0) THEN
  652.          SEGSUP MLREE1
  653.          SEGSUP MLREE2
  654.       ENDIF
  655.       IF (ISPLI.EQ.1) THEN
  656.          SEGSUP MLDERS
  657.       ENDIF
  658. *     Sortie
  659. 500   CONTINUE
  660.       RETURN
  661.       END
  662.  
  663.  
  664.  
  665.  
  666.  
  667.  
  668.  
  669.  
  670.  

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