1 : C EXTR50 SOURCE CHAT 05/01/12 23:52:38 5004 2 : SUBROUTINE EXTR50(IPOINT,BORNINF,XVAL,IPOSI) 3 : 4 : ********************************************************************** 5 : * 6 : * Extraction de la borne inf. ou sup. d'un objet NUAGE selon 7 : * les donnees du nom d'une composante reelle et de sa valeur 8 : * 9 : * INTEGER (E) IPOINT pointeur sur un objet NUAGE 10 : * LOGICAL (E) BORNINF logique valant vrai si l'on veut la 11 : * borne inf. du nuage 12 : * FLOTTANT (E) XVAL valeur de la composante reelle pour 13 : * laquelle on desire le n-uplet inferieur 14 : * ou superieur 15 : * INTEGER (E) IPOSI Position informatique de la composante 16 : * reelle du nuage 17 : * 18 : *********************************************************************** 19 : 20 : IMPLICIT INTEGER(I-N) 21 : -INC SMNUAGE 22 : 23 : REAL*8 XVAL,XVAL1,XVAL2,XVAL3 24 : INTEGER IPOINT,IPOSI,IPO2,IPOSI3,IDIM2 25 : LOGICAL BORNINF,BORNSUP 26 : CHARACTER*8 TYPR 27 : 28 : BORNSUP = .NOT.BORNINF 29 : 30 : MNUAG1 = IPOINT 31 : SEGACT MNUAG1 32 : IDIM1 = MNUAG1.NUANOM(/2) 33 : TYPR = MNUAG1.NUATYP(IPOSI) 34 : IF (TYPR.NE.'FLOTTANT') THEN 35 : SEGDES MNUAG1 36 : *- Le nom de la composante ne correspond pas a des variables reelles - 36 : CALL ERREUR(671) 37 : RETURN 38 : ENDIF 39 : NUAVF1 = MNUAG1.NUAPOI(IPOSI) 40 : SEGACT NUAVF1 41 : IDIM2 = NUAVF1.NUAFLO(/1) 42 : XVAL1 = NUAVF1.NUAFLO(1) 43 : IPOSI3 = 0 44 : IF (XVAL1.LE.XVAL.AND.BORNINF) THEN 45 : IPOSI3 = 1 46 : XVAL3 = XVAL1 47 : ENDIF 48 : IF (XVAL1.GE.XVAL.AND.BORNSUP) THEN 49 : IPOSI3 = 1 50 : XVAL3 = XVAL1 51 : ENDIF 52 : 53 : IF (IDIM2.GT.1) THEN 54 : DO 11 I=2,IDIM2 55 : XVAL2 = NUAVF1.NUAFLO(I) 56 : IF (BORNINF) THEN 57 : IF (IPOSI3.NE.0) THEN 58 : IF ((XVAL2.GT.XVAL1).AND.(XVAL2.LE.XVAL)) THEN 59 : XVAL3 = XVAL2 60 : IPOSI3 = I 61 : ENDIF 62 : ELSE 63 : IF (XVAL2.LE.XVAL) THEN 64 : XVAL3 = XVAL2 65 : IPOSI3 = I 66 : ENDIF 67 : ENDIF 68 : ELSE 69 : IF (IPOSI3.NE.0) THEN 70 : IF ((XVAL2.LT.XVAL1).AND.(XVAL2.GE.XVAL)) THEN 71 : XVAL3 = XVAL2 72 : IPOSI3 = I 73 : ENDIF 74 : ELSE 75 : IF (XVAL2.GE.XVAL) THEN 76 : XVAL3 = XVAL2 77 : IPOSI3 = I 78 : ENDIF 79 : ENDIF 80 : ENDIF 81 : 11 CONTINUE 82 : ENDIF 83 : SEGDES NUAVF1 84 : 85 : *----- La borne inf. ou sup. du NUAGE n'existe pas ---------------- 86 : 87 : IF (IPOSI3.EQ.0) THEN 88 : SEGDES MNUAG1 88 : CALL ERREUR(669) 89 : RETURN 90 : ENDIF 91 : 92 : NVAR = IDIM1 93 : NBCOUP = 1 94 : SEGINI MNUAGE 95 : IPO2 = MNUAGE 96 : DO 10 I=1,IDIM1 97 : NUANOM(I)=MNUAG1.NUANOM(I) 98 : NUATYP(I)=MNUAG1.NUATYP(I) 99 : IF (NUATYP(I).EQ.'INTEGER ') THEN 100 : SEGINI NUAVIN 101 : NUAPOI(I) = NUAVIN 102 : NUAVI1 = MNUAG1.NUAPOI(I) 103 : SEGACT NUAVI1 104 : NUAINT(1) = NUAVI1.NUAINT(IPOSI3) 105 : SEGDES NUAVI1 106 : SEGDES NUAVIN 107 : ELSE IF (NUATYP(I).EQ.'FLOTTANT') THEN 108 : SEGINI NUAVFL 109 : NUAPOI(I) = NUAVFL 110 : NUAVF1 = MNUAG1.NUAPOI(I) 111 : SEGACT NUAVF1 112 : NUAFLO(1) = NUAVF1.NUAFLO(IPOSI3) 113 : SEGDES NUAVF1 114 : SEGDES NUAVFL 115 : ELSE IF (NUATYP(I).EQ.'MOT ') THEN 116 : SEGINI NUAVMO 117 : NUAPOI(I) = NUAVMO 118 : NUAVM1 = MNUAG1.NUAPOI(I) 119 : SEGACT NUAVM1 120 : NUAMOT(1) = NUAVM1.NUAMOT(IPOSI3) 121 : SEGDES NUAVM1 122 : SEGDES NUAVMO 123 : ELSE IF (NUATYP(I).EQ.'LOGIQUE ') THEN 124 : SEGINI NUAVLO 125 : NUAPOI(I) = NUAVLO 126 : NUAVL1 = MNUAG1.NUAPOI(I) 127 : SEGACT NUAVL1 128 : NUALOG(1) = NUAVL1.NUALOG(IPOSI3) 129 : SEGDES NUAVL1 130 : SEGDES NUAVLO 131 : ELSE 132 : SEGINI NUAVIN 133 : NUAPOI(I) = NUAVIN 134 : NUAVI1 = MNUAG1.NUAPOI(I) 135 : SEGACT NUAVI1 136 : NUAINT(1) = NUAVI1.NUAINT(IPOSI3) 137 : SEGDES NUAVI1 138 : SEGDES NUAVIN 139 : END IF 140 : 10 CONTINUE 141 : 142 : SEGDES MNUAGE 143 : SEGDES MNUAG1 143 : CALL ECROBJ('NUAGE ',IPO2) 144 : RETURN 145 : END 146 : 147 :
© Cast3M 2003 - All rights reserved.
Disclaimer