Télécharger nuachl.eso

Retour à la liste

Numérotation des lignes :

nuachl
  1. C NUACHL SOURCE CB215821 20/11/04 21:19:24 10766
  2. SUBROUTINE NUACHL(ICHML)
  3. *
  4. * sous-routine de l'operateur nuage pour créer un objet nuage
  5. * à partir d'un champ par élément à composantes réelles.
  6. *
  7. IMPLICIT INTEGER(I-N)
  8. IMPLICIT REAL*8(A-H,O-Z)
  9. *
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMNUAGE
  14. -INC SMCHAML
  15. -INC SMELEME
  16. *
  17. * création d'un segment pour pouvoir créer un tableau
  18. *
  19. SEGMENT,ITABLE
  20. CHARACTER*(LOCOMP) COMPOS(N)
  21. INTEGER TABLEA(N1,N)
  22. C compos(i) : nom de la i-ème composante
  23. C tablea(j,k) : place de la k-ème composante dans le j-ème segment
  24. ENDSEGMENT
  25.  
  26. IRETOU = 0
  27. *
  28. * lecture du mchaml
  29. *
  30. MCHELM = ICHML
  31. SEGACT MCHELM
  32. N1 = ICHAML(/1)
  33. *
  34. * création du tableau
  35. *
  36. IF (N1.EQ.0) THEN
  37. NVAR = 0
  38. NCOUP = 0
  39. SEGINI MNUAGE
  40. SEGDES MNUAGE
  41. ENDIF
  42. *
  43. NBCOUP = 0
  44. DO 10 I = 1,N1
  45. MCHAML = ICHAML(I)
  46. SEGACT MCHAML
  47. N2 = NOMCHE(/2)
  48. DO 5 J = 1,N2
  49. * affichage de l'erreur dans le cas où les composantes ne sont pas
  50. * réelles
  51. IF (TYPCHE(J) .NE.'REAL*8') THEN
  52. MOTERR(1:8)=TYPCHE(J)
  53. MOTERR(17:20)=NOMCHE(J)
  54. MOTERR(21:29) = 'ARGUMENT'
  55. DO 7 K = 1,I
  56. MCHAML = ICHAML(K)
  57. SEGDES MCHAML
  58. 7 CONTINUE
  59. SEGDES MCHELM
  60. CALL ERREUR(552)
  61. RETURN
  62. ENDIF
  63. 5 CONTINUE
  64. *
  65. MELEME = IMACHE(I)
  66. SEGACT MELEME
  67. NBCOUP = NBCOUP + NUM(/1)*NUM(/2)
  68. IF (I.EQ.1) THEN
  69. N = N2
  70. SEGINI ITABLE
  71. do 20 j =1,n2
  72. compos(j) = nomche(j)
  73. tablea(i,j) = j
  74. 20 CONTINUE
  75. ELSE
  76. l = n
  77. do 40 k = 1,n2
  78. do 50 j = 1,n
  79. if (tablea(i,j).eq.0) then
  80. if (nomche(k).eq.compos(j)) then
  81. tablea(i,j) = k
  82. goto 40
  83. endif
  84. endif
  85. 50 CONTINUE
  86. l = l+1
  87. n = l
  88. segadj itable
  89. compos(l) = nomche(k)
  90. tablea(i,l) = k
  91. 40 CONTINUE
  92. ENDIF
  93. SEGDES MELEME
  94. SEGDES MCHAML
  95. 10 CONTINUE
  96.  
  97. *
  98. * initialisation de l'objet nuage
  99. *
  100. NVAR = N
  101. SEGINI MNUAGE
  102. DO 60 I =1,NVAR
  103. NUANOM(I) = COMPOS(I)
  104. NUATYP(I) = 'FLOTTANT'
  105. SEGINI NUAVFL
  106. NUAPOI(I)=NUAVFL
  107. 60 CONTINUE
  108. *
  109. * création du n-uplets du nuage
  110. *
  111. * le nuage ne contient que des flottants
  112. * boucle sur les sous zones
  113. IND = 1
  114. DO 70 I = 1,N1
  115. MCHAML = ICHAML(I)
  116. SEGACT MCHAML
  117. MELEME = IMACHE(I)
  118. SEGACT MELEME
  119. nbnn = num(/1)
  120. nbelem = num(/2)
  121. * boucle sur les éléments
  122. do 80 j = 1,nbelem
  123. * boucle sur les points
  124. do 90 k = 1,nbnn
  125. * remplissage du tableau pour chaque composante
  126. DO 100 L = 1,NVAR
  127. NUAVFL = NUAPOI(L)
  128. N3 = TABLEA(I,L)
  129. IF (N3.EQ.0) THEN
  130. NUAFLO(IND) = 0.D0
  131. ELSE
  132. MELVAL = IELVAL(N3)
  133. SEGACT MELVAL
  134. KMIN = MIN(VELCHE(/1),K)
  135. JMIN= MIN(J,VELCHE(/2))
  136. NUAFLO(IND) = VELCHE(KMIN,JMIN)
  137. SEGDES MELVAL
  138. ENDIF
  139. 100 CONTINUE
  140. IND = IND + 1
  141. 90 CONTINUE
  142. 80 CONTINUE
  143. SEGDES MELEME
  144. SEGDES MCHAML
  145. 70 CONTINUE
  146. SEGSUP ITABLE
  147. SEGDES MCHELM
  148. DO 110 I=1,NVAR
  149. NUAVFL=NUAPOI(I)
  150. SEGDES NUAVFL
  151. 110 CONTINUE
  152. SEGDES MNUAGE
  153. *
  154. * ecriture du nuage
  155. *
  156. CALL ECROBJ('NUAGE ',MNUAGE)
  157. END
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  

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