1 : C ORDONN SOURCE JC220346 12/10/09 21:15:10 7524 2 : SUBROUTINE ORDONN 3 : ************************************************************************ 4 : * 5 : * O R D O N N 6 : * ----------- 7 : * 8 : * SOUS-PROGRAMME ASSOCIE A LA DIRECTIVE "ORDONNER" 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * RANGER EN ORDRE CROISSANT OU DECROISSANT LE CONTENU D'UNE LISTE 14 : * ORDONNABLE. 15 : * "CROISSANT" EST L'OPTION PAR DEFAUT. 16 : * 17 : * PHRASE D'APPEL (EN GIBIANE): 18 : * ---------------------------- 19 : * 20 : * OBJ1 (OBJ3) = ORDONNER |(CROISSANT) | (ABSOLU) (UNIQUE) OBJ2 (OBJ4) ; 21 : * |(DECROISSANT)| 22 : * 23 : * LES PARENTHESES INDIQUANT DES OPERANDES FACULTATIFS. 24 : * 25 : * OPERANDES ET RESULTATS: 26 : * ----------------------- 27 : * 28 : * CROISSAN 'MOT ' MOT-CLE INDIQUANT QUE L'ON RANGE LE CONTENU 29 : * DE L'OBJET "LL" EN ORDRE CROISSANT. 30 : * 31 : * DECROISS 'MOT ' MOT-CLE INDIQUANT QUE L'ON RANGE LE CONTENU 32 : * DE L'OBJET "LL" EN ORDRE DECROISSANT. 33 : * 34 : * ABSOLU 'MOT ' MOT-CLE INDIQUANT QUE L'ON NE TIENT COMPTE 35 : * QUE DES VALEURS ABSOLUES DES NOMBRES DE 36 : * L'OBJET POUR FAIRE LA MISE EN ORDRE. 37 : * 38 : * UNIQUE 'MOT ' MOT-CLE INDIQUANT QUE LES DOUBLONS SONT 39 : * SUPPRIMES. 40 : * 41 : * OBJ1 'LISTREEL' OBJET QUE L'ON VEUT ORDONNER. 42 : * OU 'LISTENTI' 43 : * OU 'EVOLUTIO' 44 : * OU 'MAILLAGE' 45 : * 46 : * (OBJ2) 'LISTREEL' OBJET SUBISSANT LA MEME PERMUTATION QUE OBJ1 47 : * OU 'LISTENTI' (DANS CE CAS, OBJ1 EST UN LISTENTI OU UN 48 : * LISTREEL ET L'OPTION UNIQUE EST INACTIVE) 49 : * 50 : * SOUS-PROGRAMMES APPELES: 51 : * ------------------------ 52 : * 53 : * LIRMOT, LIRTYP, ORDON1, ORDON2, ORDON3 ,ORDON4 54 : * 55 : * AUTEUR, DATE DE CREATION: 56 : * ------------------------- 57 : * 58 : * PASCAL MANIGOT 19 MARS 1985 59 : * 60 : * OPTION "ABSOLU" AJOUTEE LE 23 AVRIL 1985 (P. MANIGOT) 61 : * 62 : * JCARDO 11/09/2012 => ORDO PASSE DE DIRECTIVE A OPERATEUR 63 : * 64 : * LANGAGE: 65 : * -------- 66 : * 67 : * FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS 68 : * 69 : ************************************************************************ 70 : * 71 : IMPLICIT INTEGER(I-N) 72 : REAL*8 x1,x2 73 : -INC CCOPTIO 74 : -INC SMLREEL 75 : -INC SMLENTI 76 : -INC SMEVOLL 77 : -INC SMELEME 78 : -INC CCREEL 79 : * 80 : PARAMETER (NBRTYP = 4) 81 : PARAMETER (NBMOTS = 4 , NBOPT = 2) 82 : * 83 : CHARACTER*8 LISTYP(NBRTYP),MONTYP 84 : CHARACTER*4 LISMOT(NBMOTS) 85 : * 86 : LOGICAL CROISS,ABSOLU,STRICT 87 : * 88 : DATA LISTYP/'LISTREEL','LISTENTI','EVOLUTIO','MAILLAGE'/ 89 : DATA LISMOT/'CROI','DECR','ABSO','UNIQ'/ 90 : * 91 : CROISS = .TRUE. 92 : ABSOLU = .FALSE. 93 : STRICT = .FALSE. 94 : * 95 : DO 100 IB100=1,NBOPT 96 : ICODE = 0 97 : NBMOT = NBMOTS 97 : CALL LIRMOT (LISMOT,NBMOT,NUMMOT,ICODE) 98 : IF (IERR .NE. 0) RETURN 99 : IF (NUMMOT .EQ. 0) THEN 100 : * --> SORTIE DE BOUCLE N.100 101 : GOTO 102 102 : ELSE IF (NUMMOT .EQ. 1) THEN 103 : CROISS = .TRUE. 104 : ELSE IF (NUMMOT .EQ. 2) THEN 105 : CROISS = .FALSE. 106 : ELSE IF (NUMMOT .EQ. 3) THEN 107 : ABSOLU = .TRUE. 108 : ELSE IF (NUMMOT .EQ. 4) THEN 109 : STRICT = .TRUE. 110 : END IF 111 : 100 CONTINUE 112 : * END DO 113 : 102 CONTINUE 114 : * 115 : ICODE = 1 116 : NBTYP = NBRTYP 116 : CALL QUETYP(MONTYP,0 ,IRETOU) 117 : IF (IRETOU.EQ.0) THEN 117 : CALL ERREUR(533) 118 : RETURN 119 : ENDIF 120 : DO 10 NUMLIS=1,NBTYP 121 : IF (MONTYP.EQ.LISTYP(NUMLIS)) GOTO 11 122 : 10 CONTINUE 123 : MOTERR(1:8)=MONTYP 123 : CALL ERREUR(39) 124 : RETURN 125 : 11 CONTINUE 125 : CALL LIROBJ(MONTYP,IPLIST,ICODE,IRETOU) 126 : IF (IERR .NE. 0) RETURN 126 : CALL LIROBJ(MONTYP,IPLI2,0,IRET2) 127 : IF (IERR .NE. 0) RETURN 128 : * 129 : * +-----------------------------------------------------+ 130 : * | O B J E T L I S T R E E L | 131 : * +-----------------------------------------------------+ 132 : * 133 : IF (NUMLIS .EQ. 1) THEN 134 : * 135 : * DEUX OBJETS LISTREEL ONT ETE FOURNIS 136 : * ************************************************* 137 : IF (IRET2.NE.0) THEN 138 : C MLREEL = IPLIST 139 : C MLREE1 = IPLI2 140 : C SEGACT MLREEL*MOD,MLREE1*MOD 141 : MLREE2 = IPLIST 142 : MLREE3 = IPLI2 143 : SEGACT,MLREE2,MLREE3 144 : SEGINI,MLREEL=MLREE2,MLREE1=MLREE3 145 : SEGDES,MLREE2,MLREE3 146 : * 147 : IF (PROG(/1).GT.MLREE1.PROG(/1)) THEN 148 : SEGDES,MLREEL,MLREE1 149 : c la seconde suite doit être au moins aussi longue 149 : CALL ERREUR(3) 150 : RETURN 151 : ENDIF 152 : JG = PROG(/1) 153 : NT1 = JG 154 : SEGINI,MLREE2 155 : JG = MLREE1.PROG(/1) 156 : SEGINI,MLREE3 157 : IF (ABSOLU) THEN 158 : DO IV = 1,JG 159 : MLREEL.PROG(IV) = DABS(MLREEL.PROG(IV)) 160 : ENDDO 161 : DO IV = 1,JG 162 : MLREE1.PROG(IV) = DABS(MLREE1.PROG(IV)) 163 : ENDDO 164 : ENDIF 164 : CALL TRIFL2(MLREEL.PROG(1),MLREE2.PROG(1), 165 : & MLREE1.PROG(1),MLREE3.PROG(1),NT1) 166 : IF (.NOT.CROISS) THEN 167 : DO IV = 1,JG 168 : MLREE2.PROG(IV) = PROG(IV) 169 : MLREE3.PROG(IV) = MLREE1.PROG(IV) 170 : ENDDO 171 : DO IV = 1,JG 172 : PROG(IV) = MLREE2.PROG(JG + 1 - IV) 173 : MLREE1.PROG(IV) = MLREE3.PROG(JG + 1 - IV) 174 : ENDDO 175 : ENDIF 176 : SEGSUP,MLREE2,MLREE3 177 : SEGDES,MLREEL,MLREE1 178 : * 178 : CALL ECROBJ('LISTREEL',MLREE1) 178 : CALL ECROBJ('LISTREEL',MLREEL) 179 : * 180 : * DEUX OBJETS LISTREEL + LISTENTI ONT ETE FOURNIS 181 : * ************************************************* 182 : ELSE 182 : CALL LIROBJ('LISTENTI',IPLI2,0,IRET2) 183 : IF (IERR .NE. 0) RETURN 184 : IF (IRET2.NE.0) THEN 185 : C MLREEL = IPLIST 186 : C MLENTI = IPLI2 187 : C SEGACT MLREEL*MOD,MLENTI*MOD 188 : MLREE1 = IPLIST 189 : MLENT1 = IPLI2 190 : SEGACT,MLREE1,MLENT1 191 : SEGINI,MLREEL=MLREE1,MLENTI=MLENT1 192 : SEGDES,MLREE1,MLENT1 193 : * 194 : IF (PROG(/1).GT.LECT(/1)) THEN 195 : SEGDES,MLREEL,MLENTI 196 : c la seconde suite doit être au moins aussi longue 196 : CALL ERREUR(3) 197 : RETURN 198 : ENDIF 199 : JG = PROG(/1) 200 : NT1 = JG 201 : SEGINI,MLREE2 202 : JG = LECT(/1) 203 : SEGINI,MLENT3 204 : IF (ABSOLU) THEN 205 : DO IV = 1,JG 206 : MLREEL.PROG(IV) = DABS(MLREEL.PROG(IV)) 207 : ENDDO 208 : DO IV = 1,JG 209 : LECT(IV) = ABS(LECT(IV)) 210 : ENDDO 211 : ENDIF 211 : CALL TRIFLO(MLREEL.PROG(1),MLREE2.PROG(1), 212 : & LECT(1),MLENT3.LECT(1),NT1) 213 : IF (.NOT.CROISS) THEN 214 : DO IV = 1,JG 215 : MLREE2.PROG(IV) = PROG(IV) 216 : MLENT3.LECT(IV) = LECT(IV) 217 : ENDDO 218 : DO IV = 1,JG 219 : PROG(IV) = MLREE2.PROG(JG + 1 - IV) 220 : LECT(IV) = MLENT3.LECT(JG + 1 - IV) 221 : ENDDO 222 : ENDIF 223 : SEGSUP,MLREE2,MLENT3 224 : SEGDES,MLREEL, MLENTI 225 : * 225 : CALL ECROBJ('LISTENTI',MLENTI) 225 : CALL ECROBJ('LISTREEL',MLREEL) 226 : * 227 : * UN SEUL OBJET LISTREEL A ETE FOURNI 228 : * ************************************************* 229 : ELSE 230 : MLREE1 = IPLIST 231 : SEGACT,MLREE1 232 : SEGINI,MLREEL=MLREE1 233 : SEGDES,MLREE1 234 : IPLIST = MLREEL 235 : * 235 : CALL ORDON1 (IPLIST,CROISS,ABSOLU) 236 : * 237 : IF (STRICT) THEN 238 : MLREE1 = IPLIST 239 : SEGACT,MLREE1 240 : JG = MLREE1.PROG(/1) 241 : IF (JG.EQ.0) GOTO 20 242 : SEGINI,MLREEL 243 : PROG(1) = MLREE1.PROG(1) 244 : X1 = PROG(1) 245 : LL = 1 246 : IF (JG.GT.1) THEN 247 : DO JJ = 2, JG 248 : X2 = MLREE1.PROG(JJ) 249 : IF (DABS(X1 - X2).GT.XSPETI*DABS(X2)) THEN 250 : LL = LL+1 251 : PROG(LL) = X2 252 : X1 = X2 253 : ENDIF 254 : ENDDO 255 : ENDIF 256 : JG = LL 257 : SEGADJ,MLREEL 258 : SEGDES,MLREEL 259 : 20 SEGDES,MLREE1 260 : ENDIF 261 : * 261 : CALL ECROBJ('LISTREEL',MLREEL) 262 : ENDIF 263 : ENDIF 264 : * 265 : * +-----------------------------------------------------+ 266 : * | O B J E T L I S T E N T I | 267 : * +-----------------------------------------------------+ 268 : * 269 : ELSEIF (NUMLIS .EQ. 2) THEN 270 : * 271 : * DEUX OBJETS LISTENTI ONT ETE FOURNIS 272 : * ************************************************* 273 : IF (IRET2.NE.0) THEN 274 : C MLENTI = IPLIST 275 : C MLENT1 = IPLI2 276 : C SEGACT MLENTI*MOD,MLENT1*MOD 277 : MLENT2 = IPLIST 278 : MLENT3 = IPLI2 279 : SEGACT,MLENT2,MLENT3 280 : SEGINI,MLENTI=MLENT2,MLENT1=MLENT3 281 : SEGDES,MLENT2,MLENT3 282 : * 283 : IF (LECT(/1).GT.MLENT1.LECT(/1)) THEN 284 : SEGDES MLENTI,MLENT1 285 : c la seconde suite doit être au moins aussi longue 285 : CALL ERREUR(3) 286 : RETURN 287 : ENDIF 288 : JG = LECT(/1) 289 : NT1 = JG 290 : SEGINI MLREEL,MLREE2 291 : DO IV = 1,JG 292 : PROG(IV) = LECT(IV) 293 : ENDDO 294 : JG = MLENT1.LECT(/1) 295 : SEGINI MLENT3 296 : IF (ABSOLU) THEN 297 : DO IV = 1,JG 298 : MLREEL.PROG(IV) = DABS(MLREEL.PROG(IV)) 299 : ENDDO 300 : DO IV = 1,JG 301 : MLENT1.LECT(IV) = ABS(MLENT1.LECT(IV)) 302 : ENDDO 303 : ENDIF 303 : CALL TRIFLO(MLREEL.PROG(1),MLREE2.PROG(1), 304 : & MLENT1.LECT(1),MLENT3.LECT(1),NT1) 305 : IF (.NOT.CROISS) THEN 306 : DO IV = 1,JG 307 : PROG(IV) = MLREE2.PROG(IV) 308 : MLENT3.LECT(IV) = MLENT1.LECT(IV) 309 : ENDDO 310 : DO IV = 1,JG 311 : PROG(IV) = MLREE2.PROG(JG + 1 - IV) 312 : MLENT1.LECT(IV) = MLENT3.LECT(JG + 1 - IV) 313 : ENDDO 314 : ENDIF 315 : DO IV = 1,NT1 316 : MLENTI.LECT(IV) = INT(MLREEL.PROG(IV)) 317 : ENDDO 318 : SEGSUP,MLREEL,MLREE2,MLENT3 319 : SEGDES,MLENTI, MLENT1 320 : * 320 : CALL ECROBJ('LISTENTI',MLENT1) 320 : CALL ECROBJ('LISTENTI',MLENTI) 321 : * 322 : * UN SEUL OBJET LISTENTI A ETE FOURNI 323 : * ************************************************* 324 : ELSE 325 : MLENT1 = IPLIST 326 : SEGACT,MLENT1 327 : SEGINI,MLENTI=MLENT1 328 : SEGDES,MLENT1 329 : IPLIST = MLENTI 330 : * 330 : CALL ORDON2 (IPLIST,CROISS,ABSOLU) 331 : IF (STRICT) THEN 332 : MLENT1 = IPLIST 333 : SEGACT MLENT1 334 : JG = MLENT1.LECT(/1) 335 : IF (JG.EQ.0) GOTO 30 336 : SEGINI MLENTI 337 : LECT(1) = MLENT1.LECT(1) 338 : M1 = LECT(1) 339 : LL = 1 340 : IF (JG.GT.1) THEN 341 : DO JJ = 2, JG 342 : M2 = MLENT1.LECT(JJ) 343 : IF (M1.NE.M2) THEN 344 : LL = LL+1 345 : LECT(LL) = M2 346 : M1 = M2 347 : ENDIF 348 : ENDDO 349 : ENDIF 350 : JG = LL 351 : SEGADJ,MLENTI 352 : SEGDES,MLENTI 353 : 30 SEGDES,MLENT1 354 : ENDIF 355 : * 355 : CALL ECROBJ('LISTENTI',MLENTI) 356 : ENDIF 357 : * 358 : * +-----------------------------------------------------+ 359 : * | O B J E T E V O L U T I O N | 360 : * +-----------------------------------------------------+ 361 : * 362 : ELSEIF (NUMLIS .EQ. 3) THEN 363 : MEVOL1 = IPLIST 364 : SEGACT,MEVOL1 365 : SEGINI,MEVOLL=MEVOL1 366 : SEGDES,MEVOL1 367 : IPLIST = MEVOLL 368 : * 368 : CALL ORDON3 (IPLIST,CROISS,ABSOLU) 369 : * 369 : CALL ECROBJ('EVOLUTIO',MEVOLL) 370 : * 371 : * +-----------------------------------------------------+ 372 : * | O B J E T M A I L L A G E | 373 : * +-----------------------------------------------------+ 374 : * 375 : ELSEIF (NUMLIS .EQ. 4) THEN 376 : IPT2 = IPLIST 377 : SEGACT,IPT2 378 : SEGINI,IPT1=IPT2 379 : SEGDES,IPT2 380 : IPLIST = IPT1 381 : * 381 : CALL ORDON4 (IPLIST) 382 : * 382 : CALL ECROBJ('MAILLAGE',IPT1) 383 : 384 : ENDIF 385 : 386 : 387 : 388 : RETURN 389 : 390 : END 391 : 392 : 393 : 394 : 395 : 396 :
© Cast3M 2003 - All rights reserved.
Disclaimer