1 : C ORDON3 SOURCE CHAT 05/01/13 02:06:04 5004 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 : * 15 : * CALL ORDON3 (IPEVOL,CROISS,ABSOLU) 16 : * 17 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 18 : * ----------- 19 : * 20 : * IPEVOL ENTIER (E) POINTEUR SUR L' EVOL A ORDONNER. 21 : * (S) MEME POINTEUR, EVOL REORDONNE . 22 : * CROISS LOGIQUE (E) INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE 23 : * CROISSANT OU NON. 24 : * ABSOLU LOGIQUE (E) INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE 25 : * EN CONSIDERANT LES VALEURS ABSOLUES OU LES 26 : * VRAIES VALEURS. 27 : * 28 : * LANGAGE: 29 : * -------- 30 : * 31 : * ESOPE + FORTRAN77 32 : * 33 : ************************************************************************ 34 : * 35 : IMPLICIT INTEGER(I-N) 36 : IMPLICIT REAL*8 (A-H,O-Z) 37 : -INC SMLREEL 38 : -INC SMEVOLL 39 : -INC CCOPTIO 40 : -INC TMCOLAC 41 : * 42 : CHARACTER*72 TI 43 : LOGICAL CROISS,ABSOLU,DECROI 44 : * 45 : DECROI = .NOT.CROISS 46 : MEVOLL=IPEVOL 47 : SEGACT MEVOLL*MOD 48 : NCOU=IEVOLL(/1) 49 : * 50 : * BOUCLE SUR LES DIFFERENTES COURBES 51 : * 52 : DO 400 NC=1,NCOU 53 : KEVOL1 = IEVOLL(NC) 54 : SEGINI,KEVOLL=KEVOL1 55 : IEVOLL(NC)=KEVOLL 56 : SEGACT KEVOLL*MOD 57 : * 58 : * TEST SUR LE TYPE DES ABSCISSES ET DES ORDONNEES 59 : * 60 : IF(TYPX(1:8).NE.'LISTREEL'.OR.TYPY(1:8).NE.'LISTREEL') THEN 60 : CALL ERREUR(19) 61 : SEGDES KEVOLL,MEVOLL 62 : RETURN 63 : ENDIF 64 : * 65 : MLREE1=IPROGX 66 : SEGINI,MLREEL=MLREE1 67 : IPROGX=MLREEL 68 : NBPT=PROG(/1) 69 : * 70 : * TEST SUR LE NOMBRE DE POINTS 71 : * 72 : IF(NBPT.EQ.1) THEN 73 : SEGDES MLREEL 74 : SEGDES KEVOLL 75 : GO TO 400 76 : ENDIF 77 : * 78 : MLREE3=IPROGY 79 : SEGINI,MLREE1=MLREE3 80 : IPROGY=MLREE1 81 : c 82 : SEGACT MLREE1*MOD 83 : DO 100 IB=2,NBPT 84 : XL1 = PROG(IB) 85 : FXL1 = MLREE1.PROG(IB) 86 : IF(ABSOLU) THEN 87 : YL1 = ABS(XL1) 88 : ELSE 89 : YL1 = XL1 90 : ENDIF 91 : IB1 = IB - 1 92 : NRANG = IB 93 : DO 110 JB=IB1,1,-1 94 : XL2 = PROG(JB) 95 : IF(ABSOLU) THEN 96 : YL2 = ABS(XL2) 97 : ELSE 98 : YL2 = XL2 99 : ENDIF 100 : IF ( (CROISS .AND. YL1.LT.YL2) 101 : & .OR. (DECROI .AND. YL1.GT.YL2) ) THEN 102 : NRANG = NRANG - 1 103 : ELSE 104 : GOTO 112 105 : END IF 106 : 110 CONTINUE 107 : 112 CONTINUE 108 : DO 120 JB=IB1,NRANG,-1 109 : PROG(JB+1) = PROG(JB) 110 : MLREE1.PROG(JB+1) = MLREE1.PROG(JB) 111 : 120 CONTINUE 112 : PROG(NRANG) = XL1 113 : MLREE1.PROG(NRANG) = FXL1 114 : 100 CONTINUE 115 : SEGDES KEVOLL,kevol1,MLREEL,MLREE1,mlree3 116 : 400 CONTINUE 117 : * 118 : SEGDES MEVOLL 119 : IF(IPSAUV.NE.0) THEN 120 : ICOLAC = IPSAUV 121 : SEGACT ICOLAC 122 : ILISSE=ILISSG 123 : SEGACT ILISSE*MOD 123 : CALL TYPFIL('EVOLUTIO',ICO) 124 : ITLACC = KCOLA(ICO) 125 : SEGACT ITLACC*MOD 125 : CALL AJOUN0(ITLACC,MEVOLL,ILISSE,1) 126 : SEGDES ICOLAC,ILISSE 127 : ENDIF 128 : RETURN 129 : END 130 : 131 : 132 : 133 : 134 : 135 : 136 :
© Cast3M 2003 - All rights reserved.
Disclaimer