Télécharger fuspr2.eso

Retour à la liste

Numérotation des lignes :

  1. C FUSPR2 SOURCE PV 16/11/17 21:59:26 9180
  2. SUBROUTINE FUSPR2(PM1,PM2,NTTPRI,
  3. $ PMTOT,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : FUSPR2
  9. C PROJET : Assemblage matrice élémentaire -> matrice Morse
  10. C DESCRIPTION : Profil Morse (non ordonné) de A + profil Morse (non
  11. C ordonné) de B => profil Morse (non ordonné) de (A + B)
  12. C
  13. C On effectue un ET sur les profils Morses non
  14. C ordonnés PM1 et PM2.
  15. C Le résultat est dans PMTOT.
  16. C Subroutine quasi-identique à FUSPRM. FUSPRM supposait
  17. C des profils morse de matrices carrées. Pas FUSPR2.
  18. C En outre, on fait tout en esope et pas en fortran
  19. C (pas robuste)
  20. C
  21. C
  22. C LANGAGE : ESOPE
  23. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  24. C mél : gounand@semt2.smts.cea.fr
  25. C***********************************************************************
  26. C APPELES :
  27. C APPELE PAR : PRASEM, MAKPMT
  28. C***********************************************************************
  29. C ENTREES : PM1, PM2
  30. C SORTIES : PMTOT
  31. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  32. C***********************************************************************
  33. C VERSION : v1, 13/12/99, version initiale
  34. C HISTORIQUE : v1, 13/12/99, création
  35. C HISTORIQUE :
  36. C HISTORIQUE :
  37. C***********************************************************************
  38. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  39. C en cas de modification de ce sous-programme afin de faciliter
  40. C la maintenance !
  41. C***********************************************************************
  42. *
  43.  
  44. -INC PPARAM
  45. -INC CCOPTIO
  46. INTEGER NTT,NJA
  47. POINTEUR PM1.PMORS
  48. POINTEUR PM2.PMORS
  49. POINTEUR PMTOT.PMORS
  50. -INC SMLENTI
  51. INTEGER JG
  52. POINTEUR IWORK.MLENTI
  53. *
  54. INTEGER IMPR,IRET
  55. *
  56. INTEGER NTTDU2,NTTDUA,NTTPRI
  57. INTEGER NNZTOT
  58. *
  59. * Executable statements
  60. *
  61. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr2'
  62. SEGACT PM1
  63. NTTDUA=PM1.IA(/1)-1
  64. SEGACT PM2
  65. NTTDU2=PM2.IA(/1)-1
  66. IF (NTTDUA.NE.NTTDU2) THEN
  67. WRITE(IOIMP,*) 'Profils morse à fusionner incompatibles...'
  68. GOTO 9999
  69. ENDIF
  70. *
  71. * Passe 1 : Effectuons le dimensionnement de PMTOT
  72. *
  73. JG=NTTPRI
  74. SEGINI,IWORK
  75. NNZTOT=0
  76. DO ITTDUA=1,NTTDUA
  77. LDG=0
  78. * Fin de la liste chaînée
  79. LAST=-1
  80. * Parcourons la ligne de A
  81. DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
  82. JACOL=PM1.JA(JNZA)
  83. IF (IWORK.LECT(JACOL).EQ.0) THEN
  84. LDG=LDG+1
  85. IWORK.LECT(JACOL)=LAST
  86. LAST=JACOL
  87. ENDIF
  88. ENDDO
  89. * Parcourons la ligne de B
  90. DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
  91. JBCOL=PM2.JA(JNZB)
  92. IF (IWORK.LECT(JBCOL).EQ.0) THEN
  93. LDG=LDG+1
  94. IWORK.LECT(JBCOL)=LAST
  95. LAST=JBCOL
  96. ENDIF
  97. ENDDO
  98. NNZTOT=NNZTOT+LDG
  99. * Remise à zéro du segment de travail
  100. DO ILDG=1,LDG
  101. IPREC=IWORK.LECT(LAST)
  102. IWORK.LECT(LAST)=0
  103. LAST=IPREC
  104. ENDDO
  105. ENDDO
  106. *
  107. * Passe 2 : Remplissage de PMTOT
  108. *
  109. NTT=NTTDUA
  110. NJA=NNZTOT
  111. SEGINI PMTOT
  112. JNZC=0
  113. PMTOT.IA(1)=1
  114. DO ITTDUA=1,NTTDUA
  115. * Parcourons la ligne de A
  116. DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
  117. JACOL=PM1.JA(JNZA)
  118. IF (IWORK.LECT(JACOL).EQ.0) THEN
  119. JNZC=JNZC+1
  120. PMTOT.JA(JNZC)=JACOL
  121. IWORK.LECT(JACOL)=JNZC
  122. ENDIF
  123. ENDDO
  124. * Parcourons la ligne de B
  125. DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
  126. JBCOL=PM2.JA(JNZB)
  127. IF (IWORK.LECT(JBCOL).EQ.0) THEN
  128. JNZC=JNZC+1
  129. PMTOT.JA(JNZC)=JBCOL
  130. IWORK.LECT(JBCOL)=JNZC
  131. ENDIF
  132. ENDDO
  133. * Remise à zéro du segment de travail
  134. DO INZC=PMTOT.IA(ITTDUA),JNZC
  135. IWORK.LECT(PMTOT.JA(INZC))=0
  136. ENDDO
  137. PMTOT.IA(ITTDUA+1)=JNZC+1
  138. ENDDO
  139. SEGSUP IWORK
  140. SEGDES PMTOT
  141. SEGDES PM2
  142. SEGDES PM1
  143. *
  144. * Normal termination
  145. *
  146. IRET=0
  147. RETURN
  148. *
  149. * Format handling
  150. *
  151. *
  152. * Error handling
  153. *
  154. 9999 CONTINUE
  155. IRET=1
  156. WRITE(IOIMP,*) 'An error was detected in subroutine fuspr2'
  157. RETURN
  158. *
  159. * End of subroutine FUSPR2
  160. *
  161. END
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  

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