1 : C EXTR53 SOURCE CHAT 05/01/12 23:52:53 5004 2 : SUBROUTINE EXTR53(IPOINT,XVAL1,XVAL2,IPOSI) 3 : 4 : ********************************************************************** 5 : * 6 : * Extraction du sous-NUAGE compris entre deux valeurs réelles 7 : * correspondant a une composante de type FLOTTANT 8 : * 9 : * INTEGER (E) IPOINT pointeur sur un objet NUAGE 10 : * FLOTTANT (E) XVAL1 valeur des composantes reelles entre 11 : * FLOTTANT (E) XVAL2 lesquelles on desire extraire le nuage 12 : * INTEGER (E) IPOSI Position informatique de la composante 13 : * reelle du nuage 14 : * 15 : *********************************************************************** 16 : 17 : IMPLICIT INTEGER(I-N) 18 : -INC SMNUAGE 19 : -INC SMLENTI 20 : 21 : REAL*8 XVAL1,XVAL2,XVAL3,BORN1,BORN2 22 : INTEGER IPOINT,IPOSI,IPO2,IDIM2,IDIM3,JG,IPOSI3,IDIM1 23 : CHARACTER*8 TYPR 24 : 25 : IF (XVAL1.LT.XVAL2) THEN 26 : BORN1 = XVAL1 27 : BORN2 = XVAL2 28 : ELSE 29 : BORN2 = XVAL1 30 : BORN1 = XVAL2 31 : ENDIF 32 : 33 : MNUAG1 = IPOINT 34 : SEGACT MNUAG1 35 : IDIM1 = MNUAG1.NUANOM(/2) 36 : TYPR = MNUAG1.NUATYP(IPOSI) 37 : IF (TYPR.NE.'FLOTTANT') THEN 38 : SEGDES MNUAG1 39 : *- Le nom de la composante ne correspond pas a des variables reelles - 39 : CALL ERREUR(671) 40 : RETURN 41 : ENDIF 42 : NUAVF1 = MNUAG1.NUAPOI(IPOSI) 43 : SEGACT NUAVF1 44 : IDIM2 = NUAVF1.NUAFLO(/1) 45 : IDIM3 = 0 46 : DO 22 I2 = 1,IDIM2 47 : XVAL3 = NUAVF1.NUAFLO(I2) 48 : IF (XVAL3.LE.BORN2.AND.XVAL3.GT.BORN1) THEN 49 : IDIM3 = IDIM3 + 1 50 : ENDIF 51 : 22 CONTINUE 52 : 53 : IF (IDIM3.EQ.0) THEN 54 : SEGDES MNUAG1 55 : SEGDES NUAVF1 56 : *------ les deux valeurs réelles définissent un nuage "vide" -------- 56 : CALL ERREUR (666) 57 : RETURN 58 : ENDIF 59 : 60 : JG = IDIM3 61 : SEGINI MLENTI 62 : ITE2 = 0 63 : DO 20 I=1,IDIM2 64 : XVAL3 = NUAVF1.NUAFLO(I) 65 : IF (XVAL3.LE.BORN2.AND.XVAL3.GT.BORN1) THEN 66 : ITE2 = ITE2 + 1 67 : LECT(ITE2) = I 68 : ENDIF 69 : 20 CONTINUE 70 : SEGDES NUAVF1 71 : 72 : NVAR = IDIM1 73 : NBCOUP = IDIM3 74 : SEGINI MNUAGE 75 : IPO2 = MNUAGE 76 : 77 : DO 21 I = 1,IDIM3 78 : IPOSI3 = LECT(I) 79 : DO 10 I2=1,IDIM1 80 : IF (I.EQ.1) THEN 81 : NUANOM(I2)=MNUAG1.NUANOM(I2) 82 : NUATYP(I2)=MNUAG1.NUATYP(I2) 83 : ENDIF 84 : IF (NUATYP(I2).EQ.'INTEGER ') THEN 85 : IF (I.EQ.1) THEN 86 : SEGINI NUAVIN 87 : NUAPOI(I2) = NUAVIN 88 : ELSE 89 : NUAVIN = NUAPOI(I2) 90 : SEGACT NUAVIN 91 : ENDIF 92 : NUAVI1 = MNUAG1.NUAPOI(I2) 93 : SEGACT NUAVI1 94 : NUAINT(I) = NUAVI1.NUAINT(IPOSI3) 95 : SEGDES NUAVI1 96 : SEGDES NUAVIN 97 : ELSE IF (NUATYP(I2).EQ.'FLOTTANT') THEN 98 : IF (I.EQ.1) THEN 99 : SEGINI NUAVFL 100 : NUAPOI(I2) = NUAVFL 101 : ELSE 102 : NUAVFL = NUAPOI(I2) 103 : SEGACT NUAVFL 104 : ENDIF 105 : NUAVF1 = MNUAG1.NUAPOI(I2) 106 : SEGACT NUAVF1 107 : NUAFLO(I) = NUAVF1.NUAFLO(IPOSI3) 108 : SEGDES NUAVF1 109 : SEGDES NUAVFL 110 : ELSE IF (NUATYP(I2).EQ.'MOT ') THEN 111 : IF (I.EQ.1) THEN 112 : SEGINI NUAVMO 113 : NUAPOI(I2) = NUAVMO 114 : ELSE 115 : NUAVMO = NUAPOI(I2) 116 : SEGACT NUAVMO 117 : ENDIF 118 : NUAVM1 = MNUAG1.NUAPOI(I2) 119 : SEGACT NUAVM1 120 : NUAMOT(I) = NUAVM1.NUAMOT(IPOSI3) 121 : SEGDES NUAVM1 122 : SEGDES NUAVMO 123 : ELSE IF (NUATYP(I2).EQ.'LOGIQUE ') THEN 124 : IF (I.EQ.1) THEN 125 : SEGINI NUAVLO 126 : NUAPOI(I2) = NUAVLO 127 : ELSE 128 : NUAVLO = NUAPOI(I2) 129 : SEGACT NUAVLO 130 : ENDIF 131 : NUAVL1 = MNUAG1.NUAPOI(I2) 132 : SEGACT NUAVL1 133 : NUALOG(I) = NUAVL1.NUALOG(IPOSI3) 134 : SEGDES NUAVL1 135 : SEGDES NUAVLO 136 : ELSE 137 : IF (I.EQ.1) THEN 138 : SEGINI NUAVIN 139 : NUAPOI(I2) = NUAVIN 140 : ELSE 141 : NUAVIN = NUAPOI(I2) 142 : SEGACT NUAVIN 143 : ENDIF 144 : NUAVI1 = MNUAG1.NUAPOI(I2) 145 : SEGACT NUAVI1 146 : NUAINT(I) = NUAVI1.NUAINT(IPOSI3) 147 : SEGDES NUAVI1 148 : SEGDES NUAVIN 149 : END IF 150 : 10 CONTINUE 151 : 21 CONTINUE 152 : 153 : SEGDES MLENTI 154 : SEGDES MNUAGE 155 : SEGDES MNUAG1 155 : CALL ECROBJ('NUAGE ',IPO2) 156 : RETURN 157 : END 158 : 159 :
© Cast3M 2003 - All rights reserved.
Disclaimer