Télécharger rednua.eso

Retour à la liste

Numérotation des lignes :

  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
  116. CALL ERREUR(675)
  117. RETURN
  118. ENDIF
  119. 1 CONTINUE
  120. *
  121. INUAR=MNUAGE
  122. *
  123. 100 CONTINUE
  124. SEGDES MNUAGE
  125. SEGDES MNUAG1
  126. SEGDES MLMOTS
  127. RETURN
  128. END
  129.  
  130.  
  131.  
  132.  
  133.  

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