Télécharger fuspr3.eso

Retour à la liste

Numérotation des lignes :

  1. C FUSPR3 SOURCE PV 16/11/17 21:59:27 9180
  2. SUBROUTINE FUSPR3(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 : FUSPR3
  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 à FUSPR3. 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 fuspr3'
  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. * WRITE(IOIMP,*) 'Partie 1'
  76. *
  77. * Passe 1 : Effectuons le dimensionnement de PMTOT
  78. *
  79. NNZTOT=0
  80. DO ITTDUA=1,NTTDDL
  81. * WRITE(IOIMP,*) 'ITTDUA=',ITTDUA
  82. LDG=0
  83. * Fin de la liste chaînée
  84. LAST=-1
  85. DO IPM=1,NBPM
  86. LDDCOU=PMORSS.LISDD(IPM)
  87. PMCOU=PMORSS.LISPM(IPM)
  88. IDX=INDEX.LECT(IPM)
  89. IF (IDX.GT.0) THEN
  90. ITTDCO=LDDCOU.LECT(IDX)
  91. IF (ITTDCO.EQ.ITTDUA) THEN
  92. * WRITE(IOIMP,*) ' IPM=',IPM
  93. * segprt,lddcou
  94. * segprt,pmcou
  95. * Parcourons la ligne de PMCOU
  96. DO JNZCOU=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
  97. JACOL=PMCOU.JA(JNZCOU)
  98. IF (IWORK.LECT(JACOL).EQ.0) THEN
  99. LDG=LDG+1
  100. * write(ioimp,*) 'iwork'
  101. IWORK.LECT(JACOL)=LAST
  102. LAST=JACOL
  103. ENDIF
  104. ENDDO
  105. IDX=IDX+1
  106. IF (IDX.LE.LDDCOU.LECT(/1)) THEN
  107. INDEX.LECT(IPM)=IDX
  108. ELSE
  109. INDEX.LECT(IPM)=0
  110. ENDIF
  111. ENDIF
  112. ENDIF
  113. ENDDO
  114. * WRITE(IOIMP,*) 'LDG=',LDG
  115. NNZTOT=NNZTOT+LDG
  116. * Remise à zéro du segment de travail
  117. DO ILDG=1,LDG
  118. IPREC=IWORK.LECT(LAST)
  119. IWORK.LECT(LAST)=0
  120. LAST=IPREC
  121. ENDDO
  122. ENDDO
  123. * WRITE(IOIMP,*) 'Partie 2'
  124. *
  125. * Passe 2 : Remplissage de PMTOT
  126. *
  127. * Rétablissement des index
  128. DO I=1,NBPM
  129. INDEX.LECT(I)=1
  130. ENDDO
  131. JG=NTTDDL
  132. NTT=NTTDDL
  133. NJA=NNZTOT
  134. SEGINI PMTOT
  135. JNZC=0
  136. PMTOT.IA(1)=1
  137. DO ITTDUA=1,NTTDDL
  138. DO IPM=1,NBPM
  139. LDDCOU=PMORSS.LISDD(IPM)
  140. PMCOU=PMORSS.LISPM(IPM)
  141. IDX=INDEX.LECT(IPM)
  142. IF (IDX.GT.0) THEN
  143. ITTDCO=LDDCOU.LECT(IDX)
  144. IF (ITTDCO.EQ.ITTDUA) THEN
  145. * Parcourons la ligne de PMCOU
  146. DO JNZA=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
  147. JACOL=PMCOU.JA(JNZA)
  148. IF (IWORK.LECT(JACOL).EQ.0) THEN
  149. JNZC=JNZC+1
  150. PMTOT.JA(JNZC)=JACOL
  151. IWORK.LECT(JACOL)=JNZC
  152. ENDIF
  153. ENDDO
  154. IDX=IDX+1
  155. IF (IDX.LE.LDDCOU.LECT(/1)) THEN
  156. INDEX.LECT(IPM)=IDX
  157. ELSE
  158. INDEX.LECT(IPM)=0
  159. ENDIF
  160. ENDIF
  161. ENDIF
  162. ENDDO
  163. * Remise à zéro du segment de travail
  164. DO INZC=PMTOT.IA(ITTDUA),JNZC
  165. IWORK.LECT(PMTOT.JA(INZC))=0
  166. ENDDO
  167. PMTOT.IA(ITTDUA+1)=JNZC+1
  168. ENDDO
  169. SEGSUP INDEX
  170. SEGSUP IWORK
  171. SEGDES PMTOT
  172. DO IPM=1,NBPM
  173. LDDCOU=PMORSS.LISDD(IPM)
  174. PMCOU=PMORSS.LISPM(IPM)
  175. SEGDES LDDCOU
  176. SEGDES PMCOU
  177. ENDDO
  178. *
  179. * Normal termination
  180. *
  181. IRET=0
  182. RETURN
  183. *
  184. * Format handling
  185. *
  186. *
  187. * Error handling
  188. *
  189. 9999 CONTINUE
  190. IRET=1
  191. WRITE(IOIMP,*) 'An error was detected in subroutine fuspr3'
  192. RETURN
  193. *
  194. * End of subroutine FUSPR3
  195. *
  196. END
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  

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