Sources Esope | Cast3M

calpco
C CALPCO    SOURCE    GOUNAND   21/06/02    21:15:06     11022          
      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 PPARAM
-INC CCOPTIO
-INC TNLIN
*-INC SMTNLIN
-INC SMLENTI
      POINTEUR POWCOF.MLENTI
*-INC 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.WELCHE(/1)
            NDCOL =MYCOF.WELCHE(/2)
            N2DLIG=MYCOF.WELCHE(/3)
            N2DCOL=MYCOF.WELCHE(/4)
            NEL=MYCOF.WELCHE(/6)
            NPG=MYCOF.WELCHE(/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.WELCHE(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.WELCHE,NPGMAX,NELMAX,
     $        MYCOF.WELCHE,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