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