C CALPCO    SOURCE    GOUNAND   06/01/18    21:15:11     5293           
      SUBROUTINE CALPCO(POWCOF,TATRAV,
     $           IPROCO,IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CALPCO
C DESCRIPTION : Calcul d'un produit de coefficients 
C               à une certaine puissance
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : 
C APPELES (E/S)    : 
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 19/12/2005, version initiale
C HISTORIQUE : v1, 19/12/2005, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
-INC CCOPTIO
CBEGININCLUDE SMPOUET
      SEGMENT TABGEO
      CHARACTER*4 DISGEO
      POINTEUR IGEO.MCHAEL
      ENDSEGMENT
      SEGMENT TABVDC
      INTEGER VVARPR(NUMVPR)
      INTEGER VVARDU(NUMVDU)
      INTEGER VDATPR(NUMDPR)
      INTEGER VDATDU(NUMDDU)
      INTEGER VCOFPR(NUMCPR)
      INTEGER VCOFDU(NUMCDU)
      INTEGER ILCPR(NUMDER+1,NUMOP,NUMVPR)
      INTEGER ILCDU(NUMDER+1,NUMOP,NUMVDU)
      POINTEUR VLCOF(JLCOF).MLENTI
      POINTEUR VCOMP(JGCOF).COMP
      POINTEUR VLDAT(JGCOF).MLENTI
      INTEGER  DJSVD(JGVD)
      POINTEUR NOMVD(JGVD).MLMOTS
      POINTEUR MVD(JGVD).MCHPOI
      REAL*8 XVD(JGVD)
      CHARACTER*4 DISVD(KGVD)
      ENDSEGMENT
      SEGMENT TATRAV
      POINTEUR VVCOF(JLCOF).MCHEVA
      POINTEUR VCOF(JGCOF).MCHEVA
      POINTEUR IVD(JGVD).MCHAEL
      POINTEUR VD(JGVD).MCHEVA
      POINTEUR DVD(JGVD).MCHEVA
      POINTEUR FFVD(KGVD).MCHEVA
      POINTEUR DFFVD(KGVD).MCHEVA
      LOGICAL LVCOF(JGCOF)
      LOGICAL LVD(JGVD)
      LOGICAL LDVD(JGVD)
      LOGICAL LFFVD(KGVD)
      LOGICAL LDFFVD(KGVD)
      ENDSEGMENT
      SEGMENT TABMAT
      POINTEUR VMAT(NUMVDU,NUMVPR).MCHAEL
      ENDSEGMENT
CENDINCLUDE SMPOUET
-INC SMLENTI
      POINTEUR POWCOF.MLENTI
CBEGININCLUDE SMCHAEL
      SEGMENT MCHAEL
      POINTEUR IMACHE(N1).MELEME
      POINTEUR ICHEVA(N1).MCHEVA
      ENDSEGMENT
      SEGMENT MCHEVA
      REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
      ENDSEGMENT
      SEGMENT LCHEVA
      POINTEUR LISCHE(NBCHE).MCHEVA
      ENDSEGMENT
CENDINCLUDE SMCHAEL
      POINTEUR LCOF.LCHEVA
      POINTEUR MYCOF.MCHEVA
* Segments où l'on stocke les nombres d'éléments et nombre de points de
* Gauss pour chaque champ à fin de vérification
      POINTEUR LNELEM.MLENTI
      POINTEUR LNPOGA.MLENTI
      POINTEUR LPOW.MLENTI
      POINTEUR IPROCO.MCHEVA
*
      INTEGER IMPR,IRET
*     
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans calpco.eso' 
*
      NBCHE=0
      SEGINI LCOF
      JG=0 
      SEGINI LNELEM
      JG=0 
      SEGINI LNPOGA
      JG=0 
      SEGINI LPOW
      SEGACT POWCOF
      JGCOF=POWCOF.LECT(/1)
      DO IJGCOF=1,JGCOF
         IPOW=POWCOF.LECT(IJGCOF)
         IF (IPOW.NE.0) THEN
            MYCOF=TATRAV.VCOF(IJGCOF)
            SEGACT MYCOF
            NDLIG =MYCOF.VELCHE(/1)
            NDCOL =MYCOF.VELCHE(/2)
            N2DLIG=MYCOF.VELCHE(/3)
            N2DCOL=MYCOF.VELCHE(/4)
            NEL=MYCOF.VELCHE(/6)
            NPG=MYCOF.VELCHE(/5)
            SEGDES MYCOF
            IF (NDLIG.NE.1.OR.NDCOL.NE.1.OR.N2DLIG.NE.1.OR.
     $           N2DCOL.NE.1) THEN
               WRITE(IOIMP,*) 'Erreur dims MYCOF'
               WRITE(IOIMP,*) 'IJGCOF=',IJGCOF
               WRITE(IOIMP,*) 'NDLIG=',NDLIG
               WRITE(IOIMP,*) 'NDCOL=',NDCOL
               WRITE(IOIMP,*) 'N2DLIG=',N2DLIG
               WRITE(IOIMP,*) 'N2DCOL=',N2DCOL
               WRITE(IOIMP,*) 'NPG   =',NPG
               WRITE(IOIMP,*) 'NEL   =',NEL
               GOTO 9999
            ENDIF
            LCOF.LISCHE(**)=MYCOF
            LNELEM.LECT(**)=NEL
            LNPOGA.LECT(**)=NPG
            LPOW.LECT(**)=IPOW
         ENDIF
      ENDDO
      SEGDES POWCOF
* Vérifications des dimensions
*   Calcul des max
      JG=LNELEM.LECT(/1)
      NELMAX=1
      NPGMAX=1
      DO IG=1,JG
         NELMAX=MAX(NELMAX,LNELEM.LECT(IG))
         NPGMAX=MAX(NPGMAX,LNPOGA.LECT(IG))
      ENDDO
*   Vérif proprement dite
      DO IG=1,JG
         NEL=LNELEM.LECT(IG)
         NPG=LNPOGA.LECT(IG)
         IF ((NPG.NE.1.AND.NPG.NE.NPGMAX)
     $     .OR.(NEL.NE.1.AND.NEL.NE.NELMAX)) THEN
            WRITE(IOIMP,*) 'Erreur dims MYCOF'
            WRITE(IOIMP,*) 'MYCOF=',LCOF.LISCHE(IG)
            WRITE(IOIMP,*) 'NPG=',NPG
            WRITE(IOIMP,*) 'NEL=',NEL
            WRITE(IOIMP,*) 'NPGMAX=',NPGMAX
            WRITE(IOIMP,*) 'NELMAX=',NELMAX
            GOTO 9999
         ENDIF
      ENDDO
*
* Initialisation du segment contenant la valeur de la loi de
* comportement
      NBLIG=1
      NBCOL=1
      N2LIG=1
      N2COL=1
      NBPOI=NPGMAX
      NBELM=NELMAX
      SEGINI IPROCO
      DO IBELM=1,NBELM
         DO IBPOI=1,NBPOI
            IPROCO.VELCHE(1,1,1,1,IBPOI,IBELM)=1.D0
         ENDDO
      ENDDO
*
* Calcul proprement dit 
*
      DO IG=1,JG
         MYCOF=LCOF.LISCHE(IG)
         NEL=LNELEM.LECT(IG)
         NPG=LNPOGA.LECT(IG)
         IPOW=LPOW.LECT(IG)
         SEGACT MYCOF
         CALL CALPC1(IPROCO.VELCHE,NPGMAX,NELMAX,
     $        MYCOF.VELCHE,NPG,NEL,IPOW,
     $        IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         SEGDES MYCOF
      ENDDO
      SEGSUP LCOF
      SEGSUP LNELEM
      SEGSUP LNPOGA
      SEGSUP LPOW
*
* Fin
*
      SEGDES IPROCO


*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine calpco'
      RETURN
*
* End of subroutine CALPCO
*
      END