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 PPARAM
  38. -INC CCOPTIO
  39. INTEGER NTT,NJA
  40. POINTEUR PMCOU.PMORS
  41. POINTEUR PMTOT.PMORS
  42. *
  43. SEGMENT PMORSS
  44. POINTEUR LISDD(NBPM).MLENTI
  45. POINTEUR LISPM(NBPM).PMORS
  46. ENDSEGMENT
  47. *
  48.  
  49. -INC SMLENTI
  50. POINTEUR LDDCOU.MLENTI
  51. POINTEUR INDEX.MLENTI
  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 fuspr4'
  62. NBPM=PMORSS.LISDD(/1)
  63. JG=NBPM
  64. SEGINI INDEX
  65. DO I=1,NBPM
  66. INDEX.LECT(I)=1
  67. ENDDO
  68. JG=NTTDDL
  69. SEGINI IWORK
  70. DO IPM=1,NBPM
  71. LDDCOU=PMORSS.LISDD(IPM)
  72. PMCOU=PMORSS.LISPM(IPM)
  73. SEGACT LDDCOU
  74. SEGACT PMCOU
  75. ENDDO
  76. *
  77. * Détermination du max de la taille des profils Morse
  78. *
  79. MAXTAI=0
  80. DO IPM=1,NBPM
  81. PMCOU=PMORSS.LISPM(IPM)
  82. MAXTAI=MAX(MAXTAI,PMCOU.JA(/1))
  83. ENDDO
  84. * Taille initiale et taille des blocs à allouer pour ajustement
  85. INITAI=MAXTAI*MIN(2,NBPM)
  86. INCTAI=MAXTAI
  87. *
  88. * Remplissage de PMTOT
  89. *
  90. JG=NTTDDL
  91. NTT=NTTDDL
  92. NJA=INITAI
  93. SEGINI PMTOT
  94. JNZC=0
  95. PMTOT.IA(1)=1
  96. DO ITTDUA=1,NTTDDL
  97. DO IPM=1,NBPM
  98. LDDCOU=PMORSS.LISDD(IPM)
  99. PMCOU=PMORSS.LISPM(IPM)
  100. IDX=INDEX.LECT(IPM)
  101. IF (IDX.GT.0) THEN
  102. ITTDCO=LDDCOU.LECT(IDX)
  103. IF (ITTDCO.EQ.ITTDUA) THEN
  104. * Parcourons la ligne de PMCOU
  105. DO JNZA=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
  106. JACOL=PMCOU.JA(JNZA)
  107. IF (IWORK.LECT(JACOL).EQ.0) THEN
  108. JNZC=JNZC+1
  109. IF (JNZC.GT.NJA) THEN
  110. NJA=NJA+INCTAI
  111. SEGADJ,PMTOT
  112. ENDIF
  113. PMTOT.JA(JNZC)=JACOL
  114. IWORK.LECT(JACOL)=JNZC
  115. ENDIF
  116. ENDDO
  117. IDX=IDX+1
  118. IF (IDX.LE.LDDCOU.LECT(/1)) THEN
  119. INDEX.LECT(IPM)=IDX
  120. ELSE
  121. INDEX.LECT(IPM)=0
  122. ENDIF
  123. ENDIF
  124. ENDIF
  125. ENDDO
  126. * Remise à zéro du segment de travail
  127. DO INZC=PMTOT.IA(ITTDUA),JNZC
  128. IWORK.LECT(PMTOT.JA(INZC))=0
  129. ENDDO
  130. PMTOT.IA(ITTDUA+1)=JNZC+1
  131. ENDDO
  132. DO IPM=1,NBPM
  133. LDDCOU=PMORSS.LISDD(IPM)
  134. PMCOU=PMORSS.LISPM(IPM)
  135. SEGDES LDDCOU
  136. SEGDES PMCOU
  137. ENDDO
  138. SEGSUP INDEX
  139. SEGSUP IWORK
  140. NJA=JNZC
  141. SEGADJ,PMTOT
  142. SEGDES PMTOT
  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 fuspr4'
  157. RETURN
  158. *
  159. * End of subroutine FUSPR4
  160. *
  161. END
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  

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