Télécharger trpmo2.eso

Retour à la liste

Numérotation des lignes :

trpmo2
  1. C TRPMO2 SOURCE PV 20/09/26 21:20:05 10724
  2. SUBROUTINE TRPMO2(LDDLDU,PMCOU,NTTDDL,
  3. $ LDDLDT,PMCOT,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : TRPMO2
  9. C PROJET : Noyau linéaire NLIN
  10. C DESCRIPTION : Construction du profil Morse (non ordonné) de (C + Ct) à
  11. C partir du profil Morse (non ordonné) de C.
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES : TRPMOR, FUSPRM
  18. C APPELE PAR : PRASEM
  19. C***********************************************************************
  20. C ENTREES : PMC
  21. C SORTIES : PMCCT
  22. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  23. C***********************************************************************
  24. C VERSION : v1, 17/03/06, version 1
  25. C HISTORIQUE : v1, 17/03/06, création
  26. C HISTORIQUE :
  27. C***********************************************************************
  28. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  29. C en cas de modification de ce sous-programme afin de faciliter
  30. C la maintenance !
  31. C***********************************************************************
  32.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. POINTEUR PMCOU.PMORS
  36. POINTEUR PMCOT.PMORS
  37. -INC SMLENTI
  38. POINTEUR LDDLDU.MLENTI
  39. POINTEUR LDDLDT.MLENTI
  40. POINTEUR KDDLDT.MLENTI
  41. POINTEUR ITRAV.MLENTI
  42. *
  43. INTEGER IMPR,IRET
  44. *
  45. * Executable statements
  46. *
  47. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans trpmo2'
  48. * SEGPRT,LDDLDU
  49. * SEGPRT,PMCOU
  50. SEGACT LDDLDU
  51. NDDLDU=LDDLDU.LECT(/1)
  52. SEGACT,PMCOU
  53. NJA=PMCOU.JA(/1)
  54. *
  55. * Trouvons la liste des ddl duaux de la transposée
  56. *
  57. JG=NTTDDL
  58. SEGINI ITRAV
  59. DO IJA=1,NJA
  60. ICOL=PMCOU.JA(IJA)
  61. ITRAV.LECT(ICOL)=ITRAV.LECT(ICOL)+1
  62. ENDDO
  63. * Dimension
  64. NDDLDT=0
  65. DO ITTDDL=1,NTTDDL
  66. IF (ITRAV.LECT(ITTDDL).GT.0) THEN
  67. NDDLDT=NDDLDT+1
  68. ENDIF
  69. ENDDO
  70. * Remplissage
  71. JG=NDDLDT
  72. SEGINI LDDLDT
  73. IDDLDT=0
  74. DO ITTDDL=1,NTTDDL
  75. IF (ITRAV.LECT(ITTDDL).GT.0) THEN
  76. IDDLDT=IDDLDT+1
  77. LDDLDT.LECT(IDDLDT)=ITTDDL
  78. ENDIF
  79. ENDDO
  80. *
  81. * Remplissage du segment IA de la transposée
  82. *
  83. NTT=NDDLDT
  84. SEGINI,PMCOT
  85. PMCOT.IA(1)=1
  86. DO IDDLDT=1,NDDLDT
  87. ICOL=LDDLDT.LECT(IDDLDT)
  88. PMCOT.IA(IDDLDT+1)=PMCOT.IA(IDDLDT)+ITRAV.LECT(ICOL)
  89. ENDDO
  90. * SEGSUP ITRAV
  91. * Repérage dans LDDLDT en réutilisant ITRAV
  92. * JG=NTTDDL
  93. * SEGINI KDDLDT
  94. KDDLDT=ITRAV
  95. CALL RSETXI(KDDLDT.LECT,LDDLDT.LECT,NDDLDT)
  96. SEGDES LDDLDT
  97. *
  98. * Remplissage de JA en se servant de IA comme liste de pointeurs
  99. * courant dans JA
  100. *
  101. DO IDDLDU=1,NDDLDU
  102. JSTRT=PMCOU.IA(IDDLDU)
  103. JSTOP=PMCOU.IA(IDDLDU+1)-1
  104. DO J=JSTRT,JSTOP
  105. * WRITE(IOIMP,*) 'J=',J
  106. JCOL=PMCOU.JA(J)
  107. * WRITE(IOIMP,*) 'JCOL=',JCOL
  108. ICOL=KDDLDT.LECT(JCOL)
  109. * WRITE(IOIMP,*) 'ICOL=',ICOL
  110. I=PMCOT.IA(ICOL)
  111. * WRITE(IOIMP,*) 'I=',I
  112. PMCOT.JA(I)=LDDLDU.LECT(IDDLDU)
  113. PMCOT.IA(ICOL)=I+1
  114. ENDDO
  115. ENDDO
  116. SEGSUP KDDLDT
  117. SEGDES PMCOU
  118. SEGDES LDDLDU
  119. *
  120. * Restauration de IA
  121. *
  122. DO IDDLDT=NDDLDT,2,-1
  123. PMCOT.IA(IDDLDT)=PMCOT.IA(IDDLDT-1)
  124. ENDDO
  125. PMCOT.IA(1)=1
  126. SEGDES PMCOT
  127. * SEGPRT,LDDLDT
  128. * SEGPRT,PMCOT
  129. *
  130. * Normal termination
  131. *
  132. IRET=0
  133. RETURN
  134. *
  135. * Format handling
  136. *
  137. *
  138. * Error handling
  139. *
  140. 9999 CONTINUE
  141. IRET=1
  142. WRITE(IOIMP,*) 'An error was detected in subroutine trpmo2'
  143. RETURN
  144. *
  145. * End of subroutine TRPMO2
  146. *
  147. END
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  

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