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

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