Télécharger mkpmor.eso

Retour à la liste

Numérotation des lignes :

  1. C MKPMOR SOURCE PV 16/11/17 22:00:50 9180
  2. SUBROUTINE MKPMOR(LPDPP,KJSPGD,KRINCP,KRINCD,
  3. $ KRSPGT,KMINCT,
  4. $ PMCOU,
  5. $ IMPR,IRET)
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. C***********************************************************************
  9. C NOM : MKPMOR
  10. C PROJET : Assemblage matrice élémentaire -> matrice Morse
  11. C DESCRIPTION : Matrice élémentaire + liste indexée d'entiers(popoin) =>
  12. C Profil Morse de la matrice assemblée (les colonnes ne
  13. C sont pas ordonnées).
  14. C
  15. C LANGAGE : ESOPE
  16. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES : CORINC
  20. C APPELE PAR : MAKPRM
  21. C***********************************************************************
  22. C ENTREES : LPDPP, KJSPGD, KRINCP, KRINCD, KRSPGT, KMINCT
  23. C SORTIES : PMCOU
  24. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  25. C***********************************************************************
  26. C VERSION : v1, 06/10/99, version initiale
  27. C HISTORIQUE : v1, 06/10/99, création
  28. C HISTORIQUE :
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  32. C en cas de modification de ce sous-programme afin de faciliter
  33. C la maintenance !
  34. C***********************************************************************
  35. *
  36. *
  37. * On peut optimiser les boucles en sortant les NPOS
  38. *
  39. *
  40. -INC CCOPTIO
  41. -INC SMELEME
  42. POINTEUR KJSPGD.MELEME
  43. POINTEUR KMINCT.MINC
  44. INTEGER NTT,NJA
  45. POINTEUR PMCOU.PMORS
  46. -INC SMLENTI
  47. INTEGER JG
  48. POINTEUR KRINCD.MLENTI
  49. POINTEUR KRIDUN.MLENTI
  50. POINTEUR KRINCP.MLENTI
  51. POINTEUR KRSPGT.MLENTI
  52. POINTEUR DD2DP.MLENTI
  53. *
  54. * Includes perso
  55. *
  56. *-INC SLSTIND
  57. *
  58. * Segment LSTIND (liste séquentielle indexée)
  59. *
  60. SEGMENT LSTIND
  61. INTEGER IDX(NBM+1)
  62. INTEGER IVAL(NBTVAL)
  63. ENDSEGMENT
  64. *
  65. * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  66. *
  67. * NBM : NOMBRE DE MULTIPLETS
  68. * NBTVAL : NOMBRE TOTAL DE VALEURS
  69. * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
  70. * MULTIPLET DANS LE TABLEAU IVAL
  71. * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  72. POINTEUR LIPUN.LSTIND
  73. POINTEUR LPDPP.LSTIND
  74. *
  75. INTEGER IMPR,IRET
  76. *
  77. LOGICAL LEXIST
  78. INTEGER IDEPA
  79. INTEGER IDUNIQ,IPUNIQ,IPDUA,IPPRI,ITTDDL
  80. INTEGER NDUNIQ,NPDUA, NTTDDL
  81. INTEGER NOPPR,NOPDU
  82. INTEGER NUTPPR,NUTPDU,NUTDPR,NUTDDU
  83. INTEGER NTOTCO,NTOTPO
  84. *
  85. * Executable statements
  86. *
  87. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mkpmor'
  88. C Pour chaque composante primale distincte, il faudrait déterminer
  89. C avec quels composantes duales distinctes il est relié :
  90. C Par exemple, si on a :
  91. C KRINCD = 1 1 1 2
  92. C KRINCP = 2 2 3 4
  93. C On a : KRIDUN = 1 2
  94. C On veut : LIPUN = (2 3) (4) (c'est une liste indexée)
  95. C
  96. CALL CORINC(KRINCD,KRINCP,
  97. $ KRIDUN,LIPUN,
  98. $ IMPR,IRET)
  99. C - Construire la liste d'entiers suivante (DD2DP) :
  100. C * Nombre d'entiers = nb total de ddl (primaux) ;
  101. C * pour chaque ddl primal : nb. total de ddl duaux qui lui
  102. C sont reliés.
  103. SEGACT KRIDUN
  104. NDUNIQ=KRIDUN.LECT(/1)
  105. SEGACT LIPUN
  106. SEGACT KJSPGD
  107. SEGACT KRSPGT
  108. SEGACT KMINCT
  109. NTOTPO=KMINCT.NPOS(/1)-1
  110. NTTDDL=KMINCT.NPOS(NTOTPO+1)-1
  111. JG=NTTDDL
  112. SEGINI DD2DP
  113. SEGACT LPDPP
  114. NPDUA=KJSPGD.NUM(/2)
  115. DO 1 IPDUA=1,NPDUA
  116. NOPDU=KJSPGD.NUM(1,IPDUA)
  117. NUTPDU=KRSPGT.LECT(NOPDU)
  118. IF (NUTPDU.EQ.0) THEN
  119. WRITE(IOIMP,*) 'C''est dual grave...'
  120. GOTO 9999
  121. ENDIF
  122. DO 12 IDUNIQ=1,NDUNIQ
  123. LEXIST=(KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ)).NE.0)
  124. IF (.NOT.LEXIST) THEN
  125. WRITE(IOIMP,*) 'C''est comp. duale grave...'
  126. GOTO 9999
  127. ENDIF
  128. NUTDDU=KMINCT.NPOS(NUTPDU)
  129. $ +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1
  130. DD2DP.LECT(NUTDDU)=(LIPUN.IDX(IDUNIQ+1)-LIPUN.IDX(IDUNIQ))
  131. $ *(LPDPP.IDX(IPDUA+1)-LPDPP.IDX(IPDUA))
  132. 12 CONTINUE
  133. 1 CONTINUE
  134. C
  135. C - Dimensionner le profil Morse
  136. C
  137. NTOTCO=0
  138. DO 3 ITTDDL=1,NTTDDL
  139. NTOTCO=NTOTCO+DD2DP.LECT(ITTDDL)
  140. 3 CONTINUE
  141. NTT=NTTDDL
  142. NJA=NTOTCO
  143. SEGINI PMCOU
  144. C
  145. C - Remplissage du profil de la matrice Morse :
  146. C * Le tableau IA :
  147. PMCOU.IA(1)=1
  148. DO 5 ITTDDL=1,NTTDDL
  149. PMCOU.IA(ITTDDL+1)=PMCOU.IA(ITTDDL)
  150. $ +DD2DP.LECT(ITTDDL)
  151. 5 CONTINUE
  152. SEGSUP DD2DP
  153. C * Le tableau JA :
  154. DO 7 IPDUA=1,NPDUA
  155. NOPDU=KJSPGD.NUM(1,IPDUA)
  156. NUTPDU=KRSPGT.LECT(NOPDU)
  157. DO 72 IDUNIQ=1,NDUNIQ
  158. NUTDDU=KMINCT.NPOS(NUTPDU)
  159. $ +KMINCT.MPOS(NUTPDU,KRIDUN.LECT(IDUNIQ))-1
  160. IDEPA=PMCOU.IA(NUTDDU)
  161. DO 722 IPPRI=LPDPP.IDX(IPDUA),LPDPP.IDX(IPDUA+1)-1
  162. NOPPR=LPDPP.IVAL(IPPRI)
  163. NUTPPR=KRSPGT.LECT(NOPPR)
  164. DO 7222 IPUNIQ=LIPUN.IDX(IDUNIQ),LIPUN.IDX(IDUNIQ+1)-1
  165. NUTDPR=KMINCT.NPOS(NUTPPR)
  166. $ +KMINCT.MPOS(NUTPPR,LIPUN.IVAL(IPUNIQ))-1
  167. PMCOU.JA(IDEPA)=NUTDPR
  168. IDEPA=IDEPA+1
  169. 7222 CONTINUE
  170. 722 CONTINUE
  171. 72 CONTINUE
  172. 7 CONTINUE
  173. SEGDES PMCOU
  174. SEGDES LPDPP
  175. SEGDES KMINCT
  176. SEGDES KRSPGT
  177. SEGDES KJSPGD
  178. SEGSUP LIPUN
  179. SEGSUP KRIDUN
  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 mkpmor'
  194. RETURN
  195. *
  196. * End of subroutine MKPMOR
  197. *
  198. END
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  

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