Télécharger la plaquette Cast3M


fr en

Télécharger ordon3.eso

Retour à la liste

Numérotation des lignes : 

ordon3

  1. C ORDON3    SOURCE    PV        21/01/21    21:15:31     10862          
  2.       SUBROUTINE ORDON3 (IPEVOL,CROISS,ABSOLU)
  3. ************************************************************************
  4. *
  5. *                             O R D O N 3
  6. *                             -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. *     RANGER EN ORDRE CROISSANT OU DECROISSANT UN 'EVOLUTIO'.
  12. *
  13. * MODE D'APPEL:
  14. * -------------
  15. *
  16. *     CALL ORDON3 (IPEVOL,CROISS,ABSOLU)
  17. *
  18. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  19. * -----------
  20. *
  21. *     IPEVOL  ENTIER    (E)  POINTEUR SUR L' EVOL  A ORDONNER.
  22. *                       (S)  MEME POINTEUR, EVOL  REORDONNE .
  23. *     CROISS  LOGIQUE   (E)  INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE
  24. *                            CROISSANT OU NON.
  25. *     ABSOLU  LOGIQUE   (E)  INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE
  26. *                            EN CONSIDERANT LES VALEURS ABSOLUES OU LES
  27. *                            VRAIES VALEURS.
  28. *
  29. * LANGAGE:
  30. * --------
  31. *
  32. *     ESOPE + FORTRAN77
  33. *
  34. ************************************************************************
  35. *
  36.       IMPLICIT INTEGER(I-N)
  37.       IMPLICIT REAL*8 (A-H,O-Z)
  38.       LOGICAL CROISS,ABSOLU,DECROI
  39.       integer IB, IB1, ICO, IPEVOL
  40.       integer IPILE, JB, NBPT, NC, NCOU, NRANG
  41.       real*8 FXL1, XL1, XL2, YL1, YL2
  42.  
  43. -INC PPARAM
  44. -INC CCOPTIO
  45. -INC COCOLL
  46. -INC SMLREEL
  47. -INC SMEVOLL
  48. -INC TMCOLAC
  49.  
  50.       pointeur piles.LISPIL
  51.       pointeur jcolac.ICOLAC
  52.       pointeur jlisse.ILISSE
  53.       pointeur jtlacc.ITLACC
  54. *
  55.       iun=1
  56. *
  57.       DECROI = .NOT.CROISS
  58.       MEVOLL=IPEVOL
  59.       SEGACT MEVOLL*MOD
  60.       NCOU=IEVOLL(/1)
  61. *
  62. *   BOUCLE SUR LES DIFFERENTES COURBES
  63. *
  64.         DO 400 NC=1,NCOU
  65.         KEVOL1 = IEVOLL(NC)
  66.         SEGINI,KEVOLL=KEVOL1
  67.         IEVOLL(NC)=KEVOLL
  68.         SEGACT KEVOLL*MOD
  69. *
  70. *  TEST SUR LE TYPE DES ABSCISSES ET DES ORDONNEES
  71. *
  72.         IF(TYPX(1:8).NE.'LISTREEL'.OR.TYPY(1:8).NE.'LISTREEL') THEN
  73.         CALL ERREUR(19)
  74.         SEGDES KEVOLL,MEVOLL
  75.         RETURN
  76.         ENDIF
  77. *
  78.         MLREE1=IPROGX
  79.         SEGINI,MLREEL=MLREE1
  80.         IPROGX=MLREEL
  81.         NBPT=PROG(/1)
  82. *
  83. *  TEST SUR LE NOMBRE DE POINTS
  84. *
  85.         IF(NBPT.EQ.1) THEN
  86.         SEGDES MLREEL
  87.         SEGDES KEVOLL
  88.         GO TO 400
  89.         ENDIF
  90. *
  91.         MLREE3=IPROGY
  92.         SEGINI,MLREE1=MLREE3
  93.         IPROGY=MLREE1
  94. c
  95.         SEGACT MLREE1*MOD
  96.          DO 100 IB=2,NBPT
  97.          XL1 = PROG(IB)
  98.          FXL1 = MLREE1.PROG(IB)
  99.          IF(ABSOLU) THEN
  100.          YL1 = ABS(XL1)
  101.          ELSE
  102.          YL1 = XL1
  103.          ENDIF
  104.          IB1 = IB - 1
  105.          NRANG = IB
  106.          DO 110 JB=IB1,1,-1
  107.             XL2 = PROG(JB)
  108.             IF(ABSOLU) THEN
  109.             YL2 = ABS(XL2)
  110.             ELSE
  111.             YL2 = XL2
  112.             ENDIF
  113.             IF ( (CROISS .AND. YL1.LT.YL2)
  114.      &      .OR. (DECROI .AND. YL1.GT.YL2) ) THEN
  115.                NRANG = NRANG - 1
  116.             ELSE
  117.                GOTO 112
  118.             END IF
  119.   110       CONTINUE
  120.   112    CONTINUE
  121.          DO 120 JB=IB1,NRANG,-1
  122.             PROG(JB+1) = PROG(JB)
  123.             MLREE1.PROG(JB+1) = MLREE1.PROG(JB)
  124.   120       CONTINUE
  125.          PROG(NRANG) = XL1
  126.          MLREE1.PROG(NRANG) = FXL1
  127.   100    CONTINUE
  128.         SEGDES KEVOLL,kevol1,MLREEL,MLREE1,mlree3
  129.  400    CONTINUE
  130. *
  131.       SEGDES MEVOLL
  132.       IF(IPSAUV.NE.0) THEN
  133.         ICOLAC = IPSAUV
  134.         SEGACT ICOLAC
  135.         ILISSE=ILISSG
  136.         SEGACT ILISSE*MOD
  137.         CALL TYPFIL('EVOLUTIO',ICO)
  138.         ITLACC = KCOLA(ICO)
  139.         SEGACT ITLACC*MOD
  140.         CALL AJOUN0(ITLACC,MEVOLL,ILISSE,iun)
  141.         SEGDES ICOLAC,ILISSE
  142.       ENDIF
  143. C     Suppression des piles d'objets communiques
  144.       if(piComm.gt.0) then
  145.          piles=piComm
  146.          segact piles
  147.          call typfil('EVOLUTIO',ico)
  148.          do ipile=1,piles.proc(/1)
  149.             jcolac= piles.proc(ipile)
  150.             if(jcolac.ne.0) then
  151.                segact jcolac
  152.                jlisse=jcolac.ilissg
  153.                segact jlisse*mod
  154.                jtlacc=jcolac.kcola(ico)
  155.                segact jtlacc*mod
  156.                call ajoun0(jtlacc,MEVOLL,jlisse,iun)
  157.                segdes jtlacc
  158.                segdes jlisse
  159.                segdes jcolac
  160.             endif
  161.          enddo
  162.          segdes piles
  163.       endif
  164.       RETURN
  165.       END
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  

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