Télécharger probap.eso

Retour à la liste

Numérotation des lignes :

  1. C PROBAP SOURCE GOUNAND 05/12/21 21:35:49 5281
  2. SUBROUTINE PROBAP(BAPOL1,BAPOL2,
  3. $ BAPROD,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : PROBAP
  9. C DESCRIPTION : Produit de deux bases polynômiales (au même sens que le
  10. C produit des éléments dans prolrf.eso)
  11. C Ex : base polynomiale (dim. 2) (1, \ksi, \eta)
  12. C * base polynomiale (dim. 1) (1, \ksi)
  13. C -> base polynomiale (dim. 3) (1, \ksi, \eta,
  14. C \zeta, \ksi\zeta, \eta\zeta)
  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 : INELQU, INELPR, INELCU
  22. C***********************************************************************
  23. C ENTREES : BAPOL1, BAPOL2
  24. C ENTREES/SORTIES : -
  25. C SORTIES : BAPROD
  26. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  27. C***********************************************************************
  28. C VERSION : v1, 10/05/2000, version initiale
  29. C HISTORIQUE : v1, 10/05/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. CBEGININCLUDE SPOLYNO
  39. SEGMENT POLYNO
  40. REAL*8 COEMON(NBMON)
  41. INTEGER EXPMON(NDIML,NBMON)
  42. ENDSEGMENT
  43. SEGMENT POLYNS
  44. POINTEUR LIPOLY(NBPOLY).POLYNO
  45. ENDSEGMENT
  46. CENDINCLUDE SPOLYNO
  47. POINTEUR BAPOL1.POLYNS
  48. POINTEUR BAPOL2.POLYNS
  49. INTEGER NBPOLY
  50. POINTEUR BAPROD.POLYNS
  51. POINTEUR POLY1.POLYNO
  52. POINTEUR POLY2.POLYNO
  53. INTEGER NBMON,NDIML
  54. POINTEUR POLYP.POLYNO
  55. *
  56. INTEGER IMPR,IRET
  57. *
  58. INTEGER NBPOL1,NBPOL2
  59. INTEGER IBPOL1,IBPOL2
  60. INTEGER NBMON1,NBMON2,NBMONP
  61. INTEGER IBMON1,IBMON2,IBMONP
  62. INTEGER NDIML1,NDIML2,NDIMLP,NDIMLT
  63. INTEGER IDIML1,IDIML2,IDIMLP
  64. *
  65. * Executable statements
  66. *
  67. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans probap.eso'
  68. * Les SEGACT et SEGDES sont dans cet ordre car on peut avoir
  69. * BAPOL1=BAPOL2
  70. SEGACT BAPOL1
  71. SEGACT BAPOL2
  72. SEGACT BAPOL1.LIPOLY(*)
  73. SEGACT BAPOL2.LIPOLY(*)
  74. NBPOL1=BAPOL1.LIPOLY(/1)
  75. NBPOL2=BAPOL2.LIPOLY(/1)
  76. POLY1=BAPOL1.LIPOLY(1)
  77. POLY2=BAPOL2.LIPOLY(1)
  78. NDIML1=POLY1.EXPMON(/1)
  79. NDIML2=POLY2.EXPMON(/1)
  80. NDIMLP=NDIML1+NDIML2
  81. NBPOLY=0
  82. SEGINI BAPROD
  83. DO 1 IBPOL2=1,NBPOL2
  84. POLY2=BAPOL2.LIPOLY(IBPOL2)
  85. NBMON2=POLY2.COEMON(/1)
  86. NDIMLT=POLY2.EXPMON(/1)
  87. IF (NDIMLT.NE.NDIML2) THEN
  88. WRITE(IOIMP,*) 'Base poly. 2 invalide'
  89. GOTO 9999
  90. ENDIF
  91. DO 12 IBPOL1=1,NBPOL1
  92. POLY1=BAPOL1.LIPOLY(IBPOL1)
  93. NBMON1=POLY1.COEMON(/1)
  94. NDIMLT=POLY1.EXPMON(/1)
  95. IF (NDIMLT.NE.NDIML1) THEN
  96. WRITE(IOIMP,*) 'Base poly. 1 invalide'
  97. GOTO 9999
  98. ENDIF
  99. NBMONP=NBMON1*NBMON2
  100. NBMON=NBMONP
  101. NDIML=NDIMLP
  102. SEGINI POLYP
  103. IBMONP=0
  104. DO 122 IBMON2=1,NBMON2
  105. DO 1222 IBMON1=1,NBMON1
  106. IBMONP=IBMONP+1
  107. POLYP.COEMON(IBMONP)=
  108. $ POLY2.COEMON(IBMON2)*POLY1.COEMON(IBMON1)
  109. IDIMLP=0
  110. DO 12222 IDIML1=1,NDIML1
  111. IDIMLP=IDIMLP+1
  112. POLYP.EXPMON(IDIMLP,IBMONP)=
  113. $ POLY1.EXPMON(IDIML1,IBMON1)
  114. 12222 CONTINUE
  115. DO 12224 IDIML2=1,NDIML2
  116. IDIMLP=IDIMLP+1
  117. POLYP.EXPMON(IDIMLP,IBMONP)=
  118. $ POLY2.EXPMON(IDIML2,IBMON2)
  119. 12224 CONTINUE
  120. 1222 CONTINUE
  121. 122 CONTINUE
  122. SEGDES POLYP
  123. BAPROD.LIPOLY(**)=POLYP
  124. 12 CONTINUE
  125. 1 CONTINUE
  126. SEGDES BAPROD
  127. SEGDES BAPOL2.LIPOLY(*)
  128. SEGDES BAPOL1.LIPOLY(*)
  129. SEGDES BAPOL2
  130. SEGDES BAPOL1
  131. *
  132. * Normal termination
  133. *
  134. IRET=0
  135. RETURN
  136. *
  137. * Format handling
  138. *
  139. *
  140. * Error handling
  141. *
  142. 9999 CONTINUE
  143. IRET=1
  144. WRITE(IOIMP,*) 'An error was detected in subroutine probap'
  145. RETURN
  146. *
  147. * End of subroutine PROBAP
  148. *
  149. END
  150.  
  151.  
  152.  
  153.  

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