C REDNUA SOURCE CHAT 05/01/13 02:47:04 5004 SUBROUTINE REDNUA(INUA,IPO1,NCOMP,INUAR,IRET) *------------------------------------------------------------------------- * redu d'un nuage sur les composantes * * ENTREES : * INUA pointeur sur un nuage * IPO1 pointeur sur les composantes * NCOMP nombre de composantes a extraire * * SORTIES: * IRET = 1 ou 0 suivant succes ou pas * INUAR = pointeur sur le nuage resultat * *------------------------------------------------------------------------- * IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMNUAGE -INC SMLMOTS * INTEGER INUAR,INUA,IPO1,IRET,NM,NU,IBOU,IBB,ISU,NCOMP,NBCOUP * IRET=1 MNUAG1=INUA SEGACT MNUAG1 NUA=MNUAG1.NUANOM(/2) * MLMOTS=IPO1 SEGACT MLMOTS * * CORRESPONDANCE ENTRE LES COMPOSANTES DEMANDEES * ET LES COMPOSANTES DU NUAGE * CREATION DU NOUVEAU NUAGE * NVAR = NCOMP SEGINI MNUAGE DO 1 IBOU=1,NCOMP ISU=0 * DO 2 IBB=1,NUA IF ((MOTS(IBOU)).EQ.(MNUAG1.NUANOM(IBB))) THEN ISU=1 NUANOM(IBOU)=MNUAG1.NUANOM(IBB) NUAPOI(IBOU)=MNUAG1.NUAPOI(IBB) NUATYP(IBOU)=MNUAG1.NUATYP(IBB) * IF ((MNUAG1.NUATYP(IBB)).EQ.('ENTIER ')) THEN NUAVI1 = MNUAG1.NUAPOI(IBB) SEGACT NUAVI1 NBCOUP=NUAVI1.NUAINT(/1) SEGINI NUAVIN DO 4 IB1 = 1, NBCOUP NUAINT(IB1) = NUAVI1.NUAINT(IB1) 4 CONTINUE SEGDES NUAVIN SEGDES NUAVI1 * ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('FLOTTANT')) THEN NUAVF1 = MNUAG1.NUAPOI(IBB) SEGACT NUAVF1 NBCOUP=NUAVF1.NUAFLO(/1) SEGINI NUAVFL DO 5 IB1 = 1, NBCOUP NUAFLO(IB1) = NUAVF1.NUAFLO(IB1) 5 CONTINUE SEGDES NUAVFL SEGDES NUAVF1 * ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('LOGIQUE')) THEN NUAVL1 = MNUAG1.NUAPOI(IBB) SEGACT NUAVL1 NBCOUP=NUAVL1.NUALOG(/1) SEGINI NUAVLO DO 6 IB1 = 1,NBCOUP NUALOG(IB1) = NUAVL1.NUALOG(IB1) 6 CONTINUE SEGDES NUAVLO SEGDES NUAVL1 * ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('MOT ')) THEN NUAVM1 = MNUAG1.NUAPOI(IBB) SEGACT NUAVM1 NBCOUP=NUAVM1.NUAMOT(/1) SEGINI NUAVMO DO 7 IB1 = 1,NBCOUP NUAMOT(IB1) = NUAVM1.NUAMOT(IB1) 7 CONTINUE SEGDES NUAVMO SEGDES NUAVM1 * ELSE NUAVI1 = MNUAG1.NUAPOI(IBB) SEGACT NUAVI1 NBCOUP=NUAVI1.NUAINT(/1) SEGINI NUAVIN DO 8 IB1 = 1,NBCOUP NUAINT(IB1) = NUAVI1.NUAINT(IB1) 8 CONTINUE SEGDES NUAVIN SEGDES NUAVI1 * * ENDIF ENDIF 2 CONTINUE * * PAS DE CORRESPONDANCE ENTRE LES COMPOSANTES * IF (ISU.EQ.0) THEN SEGDES MNUAG1 SEGDES MLMOTS SEGDES MNUAGE IRET=0 CALL ERREUR(675) RETURN ENDIF 1 CONTINUE * INUAR=MNUAGE * 100 CONTINUE SEGDES MNUAGE SEGDES MNUAG1 SEGDES MLMOTS RETURN END