1 : C REDNUA SOURCE CHAT 05/01/13 02:47:04 5004 2 : SUBROUTINE REDNUA(INUA,IPO1,NCOMP,INUAR,IRET) 3 : *------------------------------------------------------------------------- 4 : * redu d'un nuage sur les composantes 5 : * 6 : * ENTREES : 7 : * INUA pointeur sur un nuage 8 : * IPO1 pointeur sur les composantes 9 : * NCOMP nombre de composantes a extraire 10 : * 11 : * SORTIES: 12 : * IRET = 1 ou 0 suivant succes ou pas 13 : * INUAR = pointeur sur le nuage resultat 14 : * 15 : *------------------------------------------------------------------------- 16 : * 17 : IMPLICIT INTEGER(I-N) 18 : -INC CCOPTIO 19 : -INC SMNUAGE 20 : -INC SMLMOTS 21 : * 22 : INTEGER INUAR,INUA,IPO1,IRET,NM,NU,IBOU,IBB,ISU,NCOMP,NBCOUP 23 : * 24 : IRET=1 25 : MNUAG1=INUA 26 : SEGACT MNUAG1 27 : NUA=MNUAG1.NUANOM(/2) 28 : * 29 : MLMOTS=IPO1 30 : SEGACT MLMOTS 31 : * 32 : * CORRESPONDANCE ENTRE LES COMPOSANTES DEMANDEES 33 : * ET LES COMPOSANTES DU NUAGE 34 : * CREATION DU NOUVEAU NUAGE 35 : * 36 : NVAR = NCOMP 37 : SEGINI MNUAGE 38 : 39 : DO 1 IBOU=1,NCOMP 40 : ISU=0 41 : * 42 : DO 2 IBB=1,NUA 43 : IF ((MOTS(IBOU)).EQ.(MNUAG1.NUANOM(IBB))) THEN 44 : ISU=1 45 : NUANOM(IBOU)=MNUAG1.NUANOM(IBB) 46 : NUAPOI(IBOU)=MNUAG1.NUAPOI(IBB) 47 : NUATYP(IBOU)=MNUAG1.NUATYP(IBB) 48 : * 49 : IF ((MNUAG1.NUATYP(IBB)).EQ.('ENTIER ')) THEN 50 : NUAVI1 = MNUAG1.NUAPOI(IBB) 51 : SEGACT NUAVI1 52 : NBCOUP=NUAVI1.NUAINT(/1) 53 : SEGINI NUAVIN 54 : DO 4 IB1 = 1, NBCOUP 55 : NUAINT(IB1) = NUAVI1.NUAINT(IB1) 56 : 4 CONTINUE 57 : SEGDES NUAVIN 58 : SEGDES NUAVI1 59 : * 60 : ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('FLOTTANT')) THEN 61 : NUAVF1 = MNUAG1.NUAPOI(IBB) 62 : SEGACT NUAVF1 63 : NBCOUP=NUAVF1.NUAFLO(/1) 64 : SEGINI NUAVFL 65 : DO 5 IB1 = 1, NBCOUP 66 : NUAFLO(IB1) = NUAVF1.NUAFLO(IB1) 67 : 5 CONTINUE 68 : SEGDES NUAVFL 69 : SEGDES NUAVF1 70 : * 71 : ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('LOGIQUE')) THEN 72 : NUAVL1 = MNUAG1.NUAPOI(IBB) 73 : SEGACT NUAVL1 74 : NBCOUP=NUAVL1.NUALOG(/1) 75 : SEGINI NUAVLO 76 : DO 6 IB1 = 1,NBCOUP 77 : NUALOG(IB1) = NUAVL1.NUALOG(IB1) 78 : 6 CONTINUE 79 : SEGDES NUAVLO 80 : SEGDES NUAVL1 81 : * 82 : ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('MOT ')) THEN 83 : NUAVM1 = MNUAG1.NUAPOI(IBB) 84 : SEGACT NUAVM1 85 : NBCOUP=NUAVM1.NUAMOT(/1) 86 : SEGINI NUAVMO 87 : DO 7 IB1 = 1,NBCOUP 88 : NUAMOT(IB1) = NUAVM1.NUAMOT(IB1) 89 : 7 CONTINUE 90 : SEGDES NUAVMO 91 : SEGDES NUAVM1 92 : * 93 : ELSE 94 : NUAVI1 = MNUAG1.NUAPOI(IBB) 95 : SEGACT NUAVI1 96 : NBCOUP=NUAVI1.NUAINT(/1) 97 : SEGINI NUAVIN 98 : DO 8 IB1 = 1,NBCOUP 99 : NUAINT(IB1) = NUAVI1.NUAINT(IB1) 100 : 8 CONTINUE 101 : SEGDES NUAVIN 102 : SEGDES NUAVI1 103 : * 104 : * 105 : ENDIF 106 : ENDIF 107 : 2 CONTINUE 108 : * 109 : * PAS DE CORRESPONDANCE ENTRE LES COMPOSANTES 110 : * 111 : IF (ISU.EQ.0) THEN 112 : SEGDES MNUAG1 113 : SEGDES MLMOTS 114 : SEGDES MNUAGE 115 : IRET=0 115 : CALL ERREUR(675) 116 : RETURN 117 : ENDIF 118 : 1 CONTINUE 119 : * 120 : INUAR=MNUAGE 121 : * 122 : 100 CONTINUE 123 : SEGDES MNUAGE 124 : SEGDES MNUAG1 125 : SEGDES MLMOTS 126 : RETURN 127 : END 128 : 129 : 130 : 131 :
© Cast3M 2003 - All rights reserved.
Disclaimer