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. -INC CCOPTIO
  44. INTEGER NTT,NJA
  45. POINTEUR PM1.PMORS
  46. POINTEUR PM2.PMORS
  47. POINTEUR PMTOT.PMORS
  48. -INC SMLENTI
  49. INTEGER JG
  50. POINTEUR IWORK.MLENTI
  51. *
  52. INTEGER IMPR,IRET
  53. *
  54. INTEGER NTTDU2,NTTDUA,NTTPRI
  55. INTEGER NNZTOT
  56. *
  57. * Executable statements
  58. *
  59. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr2'
  60. SEGACT PM1
  61. NTTDUA=PM1.IA(/1)-1
  62. SEGACT PM2
  63. NTTDU2=PM2.IA(/1)-1
  64. IF (NTTDUA.NE.NTTDU2) THEN
  65. WRITE(IOIMP,*) 'Profils morse à fusionner incompatibles...'
  66. GOTO 9999
  67. ENDIF
  68. *
  69. * Passe 1 : Effectuons le dimensionnement de PMTOT
  70. *
  71. JG=NTTPRI
  72. SEGINI,IWORK
  73. NNZTOT=0
  74. DO ITTDUA=1,NTTDUA
  75. LDG=0
  76. * Fin de la liste chaînée
  77. LAST=-1
  78. * Parcourons la ligne de A
  79. DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
  80. JACOL=PM1.JA(JNZA)
  81. IF (IWORK.LECT(JACOL).EQ.0) THEN
  82. LDG=LDG+1
  83. IWORK.LECT(JACOL)=LAST
  84. LAST=JACOL
  85. ENDIF
  86. ENDDO
  87. * Parcourons la ligne de B
  88. DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
  89. JBCOL=PM2.JA(JNZB)
  90. IF (IWORK.LECT(JBCOL).EQ.0) THEN
  91. LDG=LDG+1
  92. IWORK.LECT(JBCOL)=LAST
  93. LAST=JBCOL
  94. ENDIF
  95. ENDDO
  96. NNZTOT=NNZTOT+LDG
  97. * Remise à zéro du segment de travail
  98. DO ILDG=1,LDG
  99. IPREC=IWORK.LECT(LAST)
  100. IWORK.LECT(LAST)=0
  101. LAST=IPREC
  102. ENDDO
  103. ENDDO
  104. *
  105. * Passe 2 : Remplissage de PMTOT
  106. *
  107. NTT=NTTDUA
  108. NJA=NNZTOT
  109. SEGINI PMTOT
  110. JNZC=0
  111. PMTOT.IA(1)=1
  112. DO ITTDUA=1,NTTDUA
  113. * Parcourons la ligne de A
  114. DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
  115. JACOL=PM1.JA(JNZA)
  116. IF (IWORK.LECT(JACOL).EQ.0) THEN
  117. JNZC=JNZC+1
  118. PMTOT.JA(JNZC)=JACOL
  119. IWORK.LECT(JACOL)=JNZC
  120. ENDIF
  121. ENDDO
  122. * Parcourons la ligne de B
  123. DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
  124. JBCOL=PM2.JA(JNZB)
  125. IF (IWORK.LECT(JBCOL).EQ.0) THEN
  126. JNZC=JNZC+1
  127. PMTOT.JA(JNZC)=JBCOL
  128. IWORK.LECT(JBCOL)=JNZC
  129. ENDIF
  130. ENDDO
  131. * Remise à zéro du segment de travail
  132. DO INZC=PMTOT.IA(ITTDUA),JNZC
  133. IWORK.LECT(PMTOT.JA(INZC))=0
  134. ENDDO
  135. PMTOT.IA(ITTDUA+1)=JNZC+1
  136. ENDDO
  137. SEGSUP IWORK
  138. SEGDES PMTOT
  139. SEGDES PM2
  140. SEGDES PM1
  141. *
  142. * Normal termination
  143. *
  144. IRET=0
  145. RETURN
  146. *
  147. * Format handling
  148. *
  149. *
  150. * Error handling
  151. *
  152. 9999 CONTINUE
  153. IRET=1
  154. WRITE(IOIMP,*) 'An error was detected in subroutine fuspr2'
  155. RETURN
  156. *
  157. * End of subroutine FUSPR2
  158. *
  159. END
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  

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