Télécharger la plaquette Cast3M


fr en

Télécharger probap.eso

Retour à la liste

Numérotation des lignes : 

probap

  1. C PROBAP    SOURCE    GOUNAND   21/06/02    21:17:31     11022          
  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.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC TNLIN      
  41. *-INC SPOLYNO
  42.       POINTEUR BAPOL1.POLYNS
  43.       POINTEUR BAPOL2.POLYNS
  44.       INTEGER NBPOLY
  45.       POINTEUR BAPROD.POLYNS
  46.       POINTEUR POLY1.POLYNO
  47.       POINTEUR POLY2.POLYNO
  48.       INTEGER NBMON,NDIML
  49.       POINTEUR POLYP.POLYNO
  50. *
  51.       INTEGER IMPR,IRET
  52. *
  53.       INTEGER NBPOL1,NBPOL2
  54.       INTEGER IBPOL1,IBPOL2
  55.       INTEGER NBMON1,NBMON2,NBMONP
  56.       INTEGER IBMON1,IBMON2,IBMONP
  57.       INTEGER NDIML1,NDIML2,NDIMLP,NDIMLT
  58.       INTEGER IDIML1,IDIML2,IDIMLP
  59. *
  60. * Executable statements
  61. *
  62.       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans probap.eso'
  63. * Les SEGACT et SEGDES sont dans cet ordre car on peut avoir
  64. * BAPOL1=BAPOL2
  65.       SEGACT BAPOL1
  66.       SEGACT BAPOL2
  67.       SEGACT BAPOL1.LIPOLY(*)
  68.       SEGACT BAPOL2.LIPOLY(*)
  69.       NBPOL1=BAPOL1.LIPOLY(/1)
  70.       NBPOL2=BAPOL2.LIPOLY(/1)
  71.       POLY1=BAPOL1.LIPOLY(1)
  72.       POLY2=BAPOL2.LIPOLY(1)
  73.       NDIML1=POLY1.EXPMON(/1)
  74.       NDIML2=POLY2.EXPMON(/1)
  75.       NDIMLP=NDIML1+NDIML2
  76.       NBPOLY=0
  77.       SEGINI BAPROD
  78.       DO 1 IBPOL2=1,NBPOL2
  79.          POLY2=BAPOL2.LIPOLY(IBPOL2)
  80.          NBMON2=POLY2.COEMON(/1)
  81.          NDIMLT=POLY2.EXPMON(/1)
  82.          IF (NDIMLT.NE.NDIML2) THEN
  83.             WRITE(IOIMP,*) 'Base poly. 2 invalide'
  84.             GOTO 9999
  85.          ENDIF
  86.          DO 12 IBPOL1=1,NBPOL1
  87.             POLY1=BAPOL1.LIPOLY(IBPOL1)
  88.             NBMON1=POLY1.COEMON(/1)
  89.             NDIMLT=POLY1.EXPMON(/1)
  90.             IF (NDIMLT.NE.NDIML1) THEN
  91.                WRITE(IOIMP,*) 'Base poly. 1 invalide'
  92.                GOTO 9999
  93.             ENDIF
  94.             NBMONP=NBMON1*NBMON2
  95.             NBMON=NBMONP
  96.             NDIML=NDIMLP
  97.             SEGINI POLYP
  98.             IBMONP=0
  99.             DO 122 IBMON2=1,NBMON2
  100.                DO 1222 IBMON1=1,NBMON1
  101.                   IBMONP=IBMONP+1
  102.                   POLYP.COEMON(IBMONP)=
  103.      $                 POLY2.COEMON(IBMON2)*POLY1.COEMON(IBMON1)
  104.                   IDIMLP=0
  105.                   DO 12222 IDIML1=1,NDIML1
  106.                      IDIMLP=IDIMLP+1
  107.                      POLYP.EXPMON(IDIMLP,IBMONP)=
  108.      $                    POLY1.EXPMON(IDIML1,IBMON1)
  109. 12222             CONTINUE
  110.                   DO 12224 IDIML2=1,NDIML2
  111.                      IDIMLP=IDIMLP+1
  112.                      POLYP.EXPMON(IDIMLP,IBMONP)=
  113.      $                    POLY2.EXPMON(IDIML2,IBMON2)
  114. 12224             CONTINUE
  115.  1222          CONTINUE
  116.  122        CONTINUE
  117.             SEGDES POLYP
  118.             BAPROD.LIPOLY(**)=POLYP
  119.  12      CONTINUE
  120.  1    CONTINUE
  121.       SEGDES BAPROD
  122.       SEGDES BAPOL2.LIPOLY(*)
  123.       SEGDES BAPOL1.LIPOLY(*)
  124.       SEGDES BAPOL2
  125.       SEGDES BAPOL1
  126. *
  127. * Normal termination
  128. *
  129.       IRET=0
  130.       RETURN
  131. *
  132. * Format handling
  133. *
  134. *
  135. * Error handling
  136. *
  137.  9999 CONTINUE
  138.       IRET=1
  139.       WRITE(IOIMP,*) 'An error was detected in subroutine probap'
  140.       RETURN
  141. *
  142. * End of subroutine PROBAP
  143. *
  144.       END
  145.  
  146.  
  147.  
  148.  
  149.  

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