Télécharger la plaquette Cast3M


fr en

Télécharger rednua.eso

Retour à la liste

Numérotation des lignes : 

rednua

  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 PPARAM
  19. -INC CCOPTIO
  20. -INC SMNUAGE
  21. -INC SMLMOTS
  22. *
  23.           INTEGER INUAR,INUA,IPO1,IRET,NM,NU,IBOU,IBB,ISU,NCOMP,NBCOUP
  24. *
  25.           IRET=1
  26.           MNUAG1=INUA
  27.           SEGACT MNUAG1
  28.              NUA=MNUAG1.NUANOM(/2)
  29. *
  30.           MLMOTS=IPO1
  31.           SEGACT MLMOTS
  32. *
  33. *   CORRESPONDANCE ENTRE LES COMPOSANTES DEMANDEES
  34. *          ET LES COMPOSANTES DU NUAGE
  35. *           CREATION DU NOUVEAU NUAGE
  36. *
  37.                NVAR = NCOMP
  38.                SEGINI MNUAGE
  39.  
  40.           DO 1 IBOU=1,NCOMP
  41.                ISU=0
  42. *
  43.               DO 2 IBB=1,NUA
  44.                 IF ((MOTS(IBOU)).EQ.(MNUAG1.NUANOM(IBB))) THEN
  45.                      ISU=1
  46.                      NUANOM(IBOU)=MNUAG1.NUANOM(IBB)
  47.                      NUAPOI(IBOU)=MNUAG1.NUAPOI(IBB)
  48.                      NUATYP(IBOU)=MNUAG1.NUATYP(IBB)
  49. *
  50.                    IF ((MNUAG1.NUATYP(IBB)).EQ.('ENTIER  ')) THEN
  51.                      NUAVI1 = MNUAG1.NUAPOI(IBB)
  52.                      SEGACT NUAVI1
  53.                      NBCOUP=NUAVI1.NUAINT(/1)
  54.                      SEGINI NUAVIN
  55.                        DO 4 IB1 = 1, NBCOUP
  56.                      NUAINT(IB1) = NUAVI1.NUAINT(IB1)
  57.   4                    CONTINUE
  58.                      SEGDES NUAVIN
  59.                      SEGDES NUAVI1
  60. *
  61.                    ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('FLOTTANT')) THEN
  62.                      NUAVF1 = MNUAG1.NUAPOI(IBB)
  63.                      SEGACT NUAVF1
  64.                      NBCOUP=NUAVF1.NUAFLO(/1)
  65.                      SEGINI NUAVFL
  66.                        DO 5 IB1 = 1, NBCOUP
  67.                      NUAFLO(IB1) = NUAVF1.NUAFLO(IB1)
  68.   5                    CONTINUE
  69.                      SEGDES NUAVFL
  70.                      SEGDES NUAVF1
  71. *
  72.                    ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('LOGIQUE')) THEN
  73.                      NUAVL1 = MNUAG1.NUAPOI(IBB)
  74.                      SEGACT NUAVL1
  75.                      NBCOUP=NUAVL1.NUALOG(/1)
  76.                      SEGINI NUAVLO
  77.                         DO 6 IB1 = 1,NBCOUP
  78.                      NUALOG(IB1) = NUAVL1.NUALOG(IB1)
  79.   6                     CONTINUE
  80.                      SEGDES NUAVLO
  81.                      SEGDES NUAVL1
  82. *
  83.                    ELSEIF ((MNUAG1.NUATYP(IBB)).EQ.('MOT    ')) THEN
  84.                      NUAVM1 = MNUAG1.NUAPOI(IBB)
  85.                      SEGACT NUAVM1
  86.                      NBCOUP=NUAVM1.NUAMOT(/1)
  87.                      SEGINI NUAVMO
  88.                        DO 7 IB1 = 1,NBCOUP
  89.                      NUAMOT(IB1) = NUAVM1.NUAMOT(IB1)
  90.   7                    CONTINUE
  91.                      SEGDES NUAVMO
  92.                      SEGDES NUAVM1
  93. *
  94.                    ELSE
  95.                      NUAVI1 = MNUAG1.NUAPOI(IBB)
  96.                      SEGACT NUAVI1
  97.                      NBCOUP=NUAVI1.NUAINT(/1)
  98.                      SEGINI NUAVIN
  99.                         DO 8 IB1 = 1,NBCOUP
  100.                      NUAINT(IB1) = NUAVI1.NUAINT(IB1)
  101.    8                    CONTINUE
  102.                      SEGDES NUAVIN
  103.                      SEGDES NUAVI1
  104. *
  105. *
  106.                    ENDIF
  107.                   ENDIF
  108.   2           CONTINUE
  109. *
  110. *   PAS DE CORRESPONDANCE ENTRE LES COMPOSANTES
  111. *
  112.                 IF (ISU.EQ.0) THEN
  113.                    SEGDES MNUAG1
  114.                    SEGDES MLMOTS
  115.                    SEGDES MNUAGE
  116.                    IRET=0
  117.                    CALL ERREUR(675)
  118.                    RETURN
  119.                ENDIF
  120.   1      CONTINUE
  121. *
  122.          INUAR=MNUAGE
  123. *
  124.   100    CONTINUE
  125.          SEGDES MNUAGE
  126.          SEGDES MNUAG1
  127.          SEGDES MLMOTS
  128.          RETURN
  129.          END
  130.  
  131.  
  132.  
  133.  
  134.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales