Télécharger fuspr4.eso

Retour à la liste

Numérotation des lignes :

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

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