Esope source files

   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 :