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.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. INTEGER NTT,NJA
  41. POINTEUR PMCOU.PMORS
  42. POINTEUR PMTOT.PMORS
  43. *
  44. SEGMENT PMORSS
  45. POINTEUR LISDD(NBPM).MLENTI
  46. POINTEUR LISPM(NBPM).PMORS
  47. ENDSEGMENT
  48. *
  49.  
  50. -INC SMLENTI
  51. POINTEUR LDDCOU.MLENTI
  52. POINTEUR INDEX.MLENTI
  53. POINTEUR IWORK.MLENTI
  54. *
  55. INTEGER IMPR,IRET
  56. *
  57. INTEGER NTTDU2,NTTDUA,NTTPRI
  58. INTEGER NNZTOT
  59. *
  60. * Executable statements
  61. *
  62. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr3'
  63. NBPM=PMORSS.LISDD(/1)
  64. JG=NBPM
  65. SEGINI INDEX
  66. DO I=1,NBPM
  67. INDEX.LECT(I)=1
  68. ENDDO
  69. JG=NTTDDL
  70. SEGINI IWORK
  71. DO IPM=1,NBPM
  72. LDDCOU=PMORSS.LISDD(IPM)
  73. PMCOU=PMORSS.LISPM(IPM)
  74. SEGACT LDDCOU
  75. SEGACT PMCOU
  76. ENDDO
  77. * WRITE(IOIMP,*) 'Partie 1'
  78. *
  79. * Passe 1 : Effectuons le dimensionnement de PMTOT
  80. *
  81. NNZTOT=0
  82. DO ITTDUA=1,NTTDDL
  83. * WRITE(IOIMP,*) 'ITTDUA=',ITTDUA
  84. LDG=0
  85. * Fin de la liste chaînée
  86. LAST=-1
  87. DO IPM=1,NBPM
  88. LDDCOU=PMORSS.LISDD(IPM)
  89. PMCOU=PMORSS.LISPM(IPM)
  90. IDX=INDEX.LECT(IPM)
  91. IF (IDX.GT.0) THEN
  92. ITTDCO=LDDCOU.LECT(IDX)
  93. IF (ITTDCO.EQ.ITTDUA) THEN
  94. * WRITE(IOIMP,*) ' IPM=',IPM
  95. * segprt,lddcou
  96. * segprt,pmcou
  97. * Parcourons la ligne de PMCOU
  98. DO JNZCOU=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
  99. JACOL=PMCOU.JA(JNZCOU)
  100. IF (IWORK.LECT(JACOL).EQ.0) THEN
  101. LDG=LDG+1
  102. * write(ioimp,*) 'iwork'
  103. IWORK.LECT(JACOL)=LAST
  104. LAST=JACOL
  105. ENDIF
  106. ENDDO
  107. IDX=IDX+1
  108. IF (IDX.LE.LDDCOU.LECT(/1)) THEN
  109. INDEX.LECT(IPM)=IDX
  110. ELSE
  111. INDEX.LECT(IPM)=0
  112. ENDIF
  113. ENDIF
  114. ENDIF
  115. ENDDO
  116. * WRITE(IOIMP,*) 'LDG=',LDG
  117. NNZTOT=NNZTOT+LDG
  118. * Remise à zéro du segment de travail
  119. DO ILDG=1,LDG
  120. IPREC=IWORK.LECT(LAST)
  121. IWORK.LECT(LAST)=0
  122. LAST=IPREC
  123. ENDDO
  124. ENDDO
  125. * WRITE(IOIMP,*) 'Partie 2'
  126. *
  127. * Passe 2 : Remplissage de PMTOT
  128. *
  129. * Rétablissement des index
  130. DO I=1,NBPM
  131. INDEX.LECT(I)=1
  132. ENDDO
  133. JG=NTTDDL
  134. NTT=NTTDDL
  135. NJA=NNZTOT
  136. SEGINI PMTOT
  137. JNZC=0
  138. PMTOT.IA(1)=1
  139. DO ITTDUA=1,NTTDDL
  140. DO IPM=1,NBPM
  141. LDDCOU=PMORSS.LISDD(IPM)
  142. PMCOU=PMORSS.LISPM(IPM)
  143. IDX=INDEX.LECT(IPM)
  144. IF (IDX.GT.0) THEN
  145. ITTDCO=LDDCOU.LECT(IDX)
  146. IF (ITTDCO.EQ.ITTDUA) THEN
  147. * Parcourons la ligne de PMCOU
  148. DO JNZA=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
  149. JACOL=PMCOU.JA(JNZA)
  150. IF (IWORK.LECT(JACOL).EQ.0) THEN
  151. JNZC=JNZC+1
  152. PMTOT.JA(JNZC)=JACOL
  153. IWORK.LECT(JACOL)=JNZC
  154. ENDIF
  155. ENDDO
  156. IDX=IDX+1
  157. IF (IDX.LE.LDDCOU.LECT(/1)) THEN
  158. INDEX.LECT(IPM)=IDX
  159. ELSE
  160. INDEX.LECT(IPM)=0
  161. ENDIF
  162. ENDIF
  163. ENDIF
  164. ENDDO
  165. * Remise à zéro du segment de travail
  166. DO INZC=PMTOT.IA(ITTDUA),JNZC
  167. IWORK.LECT(PMTOT.JA(INZC))=0
  168. ENDDO
  169. PMTOT.IA(ITTDUA+1)=JNZC+1
  170. ENDDO
  171. SEGSUP INDEX
  172. SEGSUP IWORK
  173. SEGDES PMTOT
  174. DO IPM=1,NBPM
  175. LDDCOU=PMORSS.LISDD(IPM)
  176. PMCOU=PMORSS.LISPM(IPM)
  177. SEGDES LDDCOU
  178. SEGDES PMCOU
  179. ENDDO
  180. *
  181. * Normal termination
  182. *
  183. IRET=0
  184. RETURN
  185. *
  186. * Format handling
  187. *
  188. *
  189. * Error handling
  190. *
  191. 9999 CONTINUE
  192. IRET=1
  193. WRITE(IOIMP,*) 'An error was detected in subroutine fuspr3'
  194. RETURN
  195. *
  196. * End of subroutine FUSPR3
  197. *
  198. END
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  

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