Télécharger prmcp5.eso

Retour à la liste

Numérotation des lignes :

  1. C PRMCP5 SOURCE PV 16/11/17 22:01:14 9180
  2. SUBROUTINE PRMCP5(MMLPRI,MMLDUA,MMATEL,ICMPRI,ICMDUA,LNBME,
  3. $ MPOPRI,KICPRI,KMCPRI,
  4. $ KICDUA,KMCDUA,
  5. $ MPODUA,
  6. $ IMPR,IRET)
  7. IMPLICIT INTEGER(I-N)
  8. IMPLICIT REAL*8 (A-H,O-Z)
  9. C***********************************************************************
  10. C NOM : PRMCP5
  11. C DESCRIPTION : Produit matrices élémentaires * mpoval primal
  12. C -> mpoval dual.
  13. C
  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 : REGMAI, INIRPM, RPELEM
  20. C APPELE PAR : PRMCP2
  21. C***********************************************************************
  22. C ENTREES : MLPRI, MMLDUA, MMATEL, ICMPRI, ICMDUA, LNBME,
  23. C MPOPRI, KICPRI, KMCPRI, KICDUA, KMCDUA
  24. C ENTREES/SORTIES : -
  25. C SORTIES : MPODUA
  26. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  27. C***********************************************************************
  28. C VERSION : v1, 18/04/2000, version initiale
  29. C HISTORIQUE : v1, 18/04/2000, création
  30. C HISTORIQUE :
  31. C HISTORIQUE :
  32. C***********************************************************************
  33. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  34. C en cas de modification de ce sous-programme afin de faciliter
  35. C la maintenance !
  36. C***********************************************************************
  37. -INC CCOPTIO
  38. -INC SMELEME
  39. POINTEUR MMLPRI.MELEME
  40. POINTEUR MMLDUA.MELEME
  41. POINTEUR ML2PRI.MELEME
  42. POINTEUR ML2DUA.MELEME
  43. POINTEUR SMLPRI.MELEME
  44. POINTEUR SMLDUA.MELEME
  45. POINTEUR MMATEL.IMATRI
  46. POINTEUR VMATEL.IZAFM
  47. -INC SMLENTI
  48. POINTEUR RPMAT.MLENTI
  49. POINTEUR ICMPRI.MLENTI
  50. POINTEUR ICMDUA.MLENTI
  51. POINTEUR LNBME.MLENTI
  52. POINTEUR KICPRI.MLENTI
  53. POINTEUR KICDUA.MLENTI
  54. POINTEUR KMCPRI.MLENTI
  55. POINTEUR KMCDUA.MLENTI
  56. -INC SMCHPOI
  57. POINTEUR MPOPRI.MPOVAL
  58. POINTEUR MPODUA.MPOVAL
  59. *
  60. INTEGER IMPR,IRET
  61. *
  62. INTEGER ICCPRI,ICCDUA,ILMAT,NUELG,NUELOC,ITPOPR,ITPODU
  63. INTEGER IELEM ,IMATL ,IPMAT,JDMAT, ISOUM,ISOUMA,OLDISM
  64. INTEGER NELPRI,NMATL ,NPMAT,NDMAT,NBSOUM,NBSOUP,NBSOUD
  65. LOGICAL LPARTP,LPARTD
  66. *
  67. * Executable statements
  68. *
  69. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans prmcp5.eso'
  70. * On régularise les maillage pour plus se faire chier si LISOUS(/1).EQ.0
  71. * In REGMAI : IF (.NOT.LPARTD) SEGINI ML2DUA
  72. CALL REGMAI(MMLDUA,ML2DUA,LPARTD,IMPR,IRET)
  73. IF (IRET.NE.0) GOTO 9999
  74. * In REGMAI : IF (.NOT.LPARTP) SEGINI ML2PRI
  75. CALL REGMAI(MMLPRI,ML2PRI,LPARTP,IMPR,IRET)
  76. IF (IRET.NE.0) GOTO 9999
  77. *
  78. * Activons les chapeaux (Matrices et supports)
  79. *
  80. SEGACT ML2DUA
  81. NBSOUD=ML2DUA.LISOUS(/1)
  82. SEGACT ML2PRI
  83. NBSOUP=ML2PRI.LISOUS(/1)
  84. SEGACT MMATEL
  85. NBSOUM=NBSOUP
  86. IF (NBSOUD.NE.NBSOUP) THEN
  87. WRITE(IOIMP,*) 'Maillage primal, dual :'
  88. WRITE(IOIMP,*) 'partitionnment différent...'
  89. WRITE(IOIMP,*) 'NBSOUD=',NBSOUD
  90. WRITE(IOIMP,*) 'NBSOUP=',NBSOUP
  91. GOTO 9999
  92. ENDIF
  93. *
  94. * Tableau de repérage dans la matrice
  95. *
  96. * In INIRPM : SEGINI RPMAT
  97. CALL INIRPM(MMATEL,RPMAT,IMPR,IRET)
  98. IF (IRET.NE.0) GOTO 9999
  99. *
  100. * Activons les tableaux de repérage
  101. *
  102. * Matrices
  103. * Inconnues
  104. SEGACT ICMPRI
  105. SEGACT ICMDUA
  106. * Matrices élémentaires à parcourir
  107. SEGACT LNBME
  108. * Chpoints
  109. SEGACT MPOPRI
  110. SEGACT MPODUA*MOD
  111. * Inconnues
  112. SEGACT KICPRI
  113. SEGACT KICDUA
  114. * Maillages
  115. SEGACT KMCPRI
  116. SEGACT KMCDUA
  117. *
  118. * Parcourons les matrices élémentaires par sous-domaine et
  119. * remplissons les valeurs de MPODUA.
  120. *
  121. NMATL=LNBME.LECT(/1)
  122. DO 1 IMATL=1,NMATL
  123. * Numéros d'inconnues dans les chpo. primaux et duaux
  124. * pour la LNBME.LECT(IMATL)ième matrice
  125. ICCPRI=KICPRI.LECT(ICMPRI.LECT(LNBME.LECT(IMATL)))
  126. ICCDUA=KICDUA.LECT(ICMDUA.LECT(LNBME.LECT(IMATL)))
  127. NUELG=0
  128. OLDISM=1
  129. VMATEL=MMATEL.LIZAFM(OLDISM,LNBME.LECT(IMATL))
  130. SEGACT VMATEL
  131. DO 12 ISOUM=1,NBSOUM
  132. SMLDUA=ML2DUA.LISOUS(ISOUM)
  133. SEGACT SMLDUA
  134. SMLPRI=ML2PRI.LISOUS(ISOUM)
  135. SEGACT SMLPRI
  136. NELPRI=SMLPRI.NUM(/2)
  137. DO 122 IELEM=1,NELPRI
  138. NUELG=NUELG+1
  139. CALL RPELEM(NUELG,RPMAT,ISOUMA,NUELOC,IMPR,IRET)
  140. IF (IRET.NE.0) GOTO 9999
  141. ISOUMA=MAX(ISOUMA,1)
  142. IF (ISOUMA.NE.OLDISM) THEN
  143. SEGDES VMATEL
  144. VMATEL=MMATEL.LIZAFM(ISOUMA,LNBME.LECT(IMATL))
  145. SEGACT VMATEL
  146. OLDISM=ISOUMA
  147. ENDIF
  148. ILMAT=NUELOC
  149. NPMAT=VMATEL.AM(/2)
  150. NDMAT=VMATEL.AM(/3)
  151. DO 1222 JDMAT=1,NDMAT
  152. ITPODU=KMCDUA.LECT(SMLDUA.NUM(JDMAT,IELEM))
  153. IF (ITPODU.EQ.0) THEN
  154. WRITE(IOIMP,*) 'Point dual ????'
  155. GOTO 9999
  156. ENDIF
  157. DO 12222 IPMAT=1,NPMAT
  158. ITPOPR=KMCPRI.LECT(SMLPRI.NUM(IPMAT,IELEM))
  159. * IF (ITPOPR.EQ.0) THEN
  160. * WRITE(IOIMP,*) 'Un point du chpo. primal ',
  161. * $ 'n''est pas dans le spg primal de la ',
  162. * $ 'matrice..'
  163. * GOTO 9999
  164. * ENDIF
  165. IF (ITPOPR.NE.0) THEN
  166. MPODUA.VPOCHA(ITPODU,ICCDUA)=
  167. $ MPODUA.VPOCHA(ITPODU,ICCDUA)+
  168. $ (VMATEL.AM(ILMAT,IPMAT,JDMAT)
  169. $ *MPOPRI.VPOCHA(ITPOPR,ICCPRI))
  170. ENDIF
  171. 12222 CONTINUE
  172. 1222 CONTINUE
  173. 122 CONTINUE
  174. SEGDES SMLPRI
  175. SEGDES SMLDUA
  176. 12 CONTINUE
  177. SEGDES VMATEL
  178. 1 CONTINUE
  179. *
  180. * Désactivons les tableaux de repérage
  181. *
  182. SEGDES KMCDUA
  183. SEGDES KMCPRI
  184. SEGDES KICDUA
  185. SEGDES KICPRI
  186. SEGDES MPODUA
  187. SEGDES MPOPRI
  188. SEGDES LNBME
  189. SEGDES ICMDUA
  190. SEGDES ICMPRI
  191. SEGDES RPMAT
  192. SEGDES MMATEL
  193. SEGDES ML2PRI
  194. SEGDES ML2DUA
  195. IF (.NOT.LPARTP) SEGSUP ML2PRI
  196. IF (.NOT.LPARTD) SEGSUP ML2DUA
  197. *
  198. * Normal termination
  199. *
  200. IRET=0
  201. RETURN
  202. *
  203. * Format handling
  204. *
  205. *
  206. * Error handling
  207. *
  208. 9999 CONTINUE
  209. IRET=1
  210. WRITE(IOIMP,*) 'An error was detected in subroutine prmcp5'
  211. RETURN
  212. *
  213. * End of subroutine PRMCP5
  214. *
  215. END
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  

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