Télécharger la plaquette Cast3M


fr en

Télécharger prolon.eso

Retour à la liste

Numérotation des lignes : 

prolon

  1. C PROLON    SOURCE    PASCAL    21/03/09    21:15:07     10917          
  2.       SUBROUTINE PROLON
  3. C
  4. C=======================================================================
  5. C
  6. C     Opérateur PROL
  7. C
  8. C     SYNTAXE : voir notice
  9. C
  10. C=======================================================================
  11. C
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14.       PARAMETER (NCLE=2)
  15.       CHARACTER*4 LMCLE(NCLE)
  16.       CHARACTER*4 LNOID(1)
  17.       DATA LMCLE/'BORN','LINE'/
  18.       DATA LNOID/'NOID'/
  19.  
  20. -INC CCREEL
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMEVOLL
  24. -INC SMLREEL
  25.  
  26. C---- Lecture des arguments
  27.  
  28. *     Lecture mot Option
  29.       CALL LIRMOT(LMCLE,NCLE,ICLE,0)
  30.       IF (ICLE.EQ.0) ICLE = 1
  31.  
  32. *     Lecture de la fonction à extrapoler
  33.       CALL LIROBJ('EVOLUTIO',IEV1,1,IRETOU)
  34.       IF (IERR.NE.0) RETURN
  35.  
  36. *     Analyse EVOLUTION 
  37.       CALL ACTOBJ('EVOLUTIO',IEV1,1)
  38.       IF (IERR.NE.0) RETURN
  39.       MEVOLL = IEV1
  40.       NEV1   = IEVOLL(/1)
  41.       IF (NEV1.EQ.0) GOTO 900
  42.       DO 10 I1=1,NEV1
  43.         KEVOLL = IEVOLL(I1)
  44.         IF ((TYPX.NE.'LISTREEL').OR.(TYPY.NE.'LISTREEL')) THEN
  45.           CALL ERREUR(1116)
  46.           RETURN
  47.         ENDIF
  48.  10   CONTINUE 
  49.  
  50. *     Lecture valeur a laquelle extrapoler la fonction
  51.       CALL LIRREE(FLOT1,1,IRETOU)
  52.       IF (IERR.NE.0) RETURN
  53.       CALL LIRREE(FLOT2,0,IFLOT2)
  54.  
  55. C Je debranche l'option NOID car conflit avec donnee FLOT1, FLOT2...
  56. C 20   CONTINUE 
  57. *     Lecture mot-cle "NOID"
  58. C      CALL LIRMOT(LNOID,1,INOID,0)
  59. C      IF (NEV1.EQ.0) THEN
  60. C        IF (INOID.EQ.0) THEN
  61. C          GOTO 900
  62. C        ELSE
  63. C          GOTO 910
  64. C        ENDIF
  65. C      ENDIF
  66.  
  67. C---- Calcul prolongement
  68.  
  69. C     Boucle si IFLOT2
  70.  99   CONTINUE 
  71.  
  72. *     Initialisation courbe solution
  73.       N = NEV1
  74.       SEGINI,MEVOL1
  75.  
  76. C     NMOD1 : on compte les courbes modifiees
  77.       NMOD1 = 0
  78.       DO 100 I1=1,NEV1
  79.         KEVOLL = IEVOLL(I1)
  80. C       write(6,*) 'KEVOLL =',KEVOLL
  81.         MLREEL = IPROGX
  82.         MLREE1 = IPROGY
  83. C
  84. C       Test longueur abscisse (objets vides !)
  85.         JG     = PROG(/1)
  86.         IF (JG.EQ.0) THEN
  87.           MOTERR(1:8) = 'LISTREEL'
  88.           INTERR = MLREEL
  89.           CALL ERREUR(356)
  90.           RETURN
  91.         ENDIF
  92. C
  93. C       Extrapolation valeur fonction selon option :
  94.         CALL INTER5(FLOT1,MLREEL,MLREE1,FT0,0,0,ICLE,IRET)
  95.         IF (IERR.NE.0) RETURN
  96. C
  97. C       Cas a gauche de la borne :
  98.         IF (FLOT1.LT.PROG(1)) THEN
  99.           JG = JG + 1
  100.           SEGINI,MLREE2,MLREE3
  101.           MLREE2.PROG(1) = FLOT1
  102.           MLREE3.PROG(1) = FT0
  103.           DO 120 IX=2,JG
  104.             MLREE2.PROG(IX) = MLREEL.PROG(IX-1)
  105.             MLREE3.PROG(IX) = MLREE1.PROG(IX-1)
  106.  120      CONTINUE
  107.  
  108. C         Creation de la I1e courbe :
  109.           SEGINI,KEVOL1  
  110.           KEVOL1.IPROGX = MLREE2
  111.           KEVOL1.IPROGY = MLREE3
  112.           KEVOL1.NUMEVX = NUMEVX
  113.           KEVOL1.NUMEVY = NUMEVY
  114.           KEVOL1.TYPX   = TYPX
  115.           KEVOL1.TYPY   = TYPY
  116.           KEVOL1.NOMEVX = NOMEVX
  117.           KEVOL1.NOMEVY = NOMEVY
  118.           KEVOL1.KEVTEX = KEVTEX
  119.  
  120.           NMOD1 = NMOD1 + 1
  121.  
  122. C       Cas a droite de la borne :
  123.         ELSEIF (FLOT1.GT.PROG(JG)) THEN
  124.           SEGINI,MLREE2=MLREEL
  125.           SEGINI,MLREE3=MLREE1
  126.           JG = JG + 1
  127.           SEGADJ,MLREE2,MLREE3
  128.           MLREE2.PROG(JG) = FLOT1
  129.           MLREE3.PROG(JG) = FT0
  130.  
  131. C         Creation de la I1e courbe :
  132.           SEGINI,KEVOL1  
  133.           KEVOL1.IPROGX = MLREE2
  134.           KEVOL1.IPROGY = MLREE3
  135.           KEVOL1.NUMEVX = NUMEVX
  136.           KEVOL1.NUMEVY = NUMEVY
  137.           KEVOL1.TYPX   = TYPX
  138.           KEVOL1.TYPY   = TYPY
  139.           KEVOL1.NOMEVX = NOMEVX
  140.           KEVOL1.NOMEVY = NOMEVY
  141.           KEVOL1.KEVTEX = KEVTEX
  142.  
  143.           NMOD1 = NMOD1 + 1
  144.  
  145. C       Cas dans le domaine de definition
  146.         ELSE
  147.           KEVOL1 = KEVOLL
  148.         ENDIF
  149. C
  150. C       Ajout I1e courbe a EVOL resultat
  151.         MEVOL1.IEVOLL(I1) = KEVOL1
  152.         MEVOL1.ITYEVO = ITYEVO
  153.         MEVOL1.IEVTEX = IEVTEX
  154.  
  155.  100  CONTINUE
  156.  
  157. C     SI FLOT2, on recommence :
  158.       IF (IFLOT2.NE.0) THEN
  159.         IFLOT2 = 0
  160.         FLOT1  = FLOT2
  161.         MEVOLL = MEVOL1
  162.         GOTO 99
  163.       ENDIF
  164.  
  165. C---- Sorties
  166.       IF (NMOD1.EQ.0) GOTO 910
  167.       CALL ECROBJ('EVOLUTIO',MEVOL1)
  168.       RETURN
  169.  
  170. C     L'evolution est vide et pas NOID
  171.  900  CONTINUE
  172.       MOTERR(1:8)='EVOLUTIO'
  173.       CALL ERREUR(1027)
  174.       RETURN
  175.  
  176. C     On renvoie l'evolution en entree :
  177.  910  CONTINUE
  178.       CALL ECROBJ('EVOLUTIO',MEVOLL)
  179.       RETURN
  180.  
  181.       END
  182.  
  183.  

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