Sources Esope | Cast3M

cpropg
C CPROPG    SOURCE    GOUNAND   21/06/02    21:15:32     11022          
      SUBROUTINE CPROPG(PGPRO1,PGPRO2,
     $     PGCOUR,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CPROPG
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : Construit les coordonnées et poids pour des règles
C               d'intégration "produit conique" (conical product)
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : -
C APPELE PAR       : INGATR, INGATE
C***********************************************************************
C ENTREES            : PGPRO1, PGPRO2
C ENTREES/SORTIES    : PGCOUR (actif en *MOD)
C SORTIES            : -
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 14/06/2000, version initiale
C HISTORIQUE : v1, 14/06/2000, 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 SPOGAU
      POINTEUR PGCOUR.POGAU
      POINTEUR PGPRO1.POGAU
      POINTEUR PGPRO2.POGAU
*
      INTEGER IMPR,IRET
*
      INTEGER NBPG1,NBPG2,NBPGC
      INTEGER IBPG1,IBPG2,IBPGC
      INTEGER NDIML1,NDIML2,NDIMLC
      INTEGER IDIML1,       IDIMLC
*
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans cpropg.eso'
      SEGACT PGPRO1
      SEGACT PGPRO2
      NDIML1=PGPRO1.XCOPG(/1)
      NBPG1 =PGPRO1.XCOPG(/2)
      NDIML2=PGPRO2.XCOPG(/1)
      NBPG2 =PGPRO2.XCOPG(/2)
      NDIMLC=PGCOUR.XCOPG(/1)
      NBPGC =PGCOUR.XCOPG(/2)
      IF ((NDIML1+NDIML2).NE.NDIMLC) THEN
         WRITE(IOIMP,*) 'Err. dim. esp.'
         GOTO 9999
      ENDIF
      IF ((NBPG1*NBPG2).NE.NBPGC) THEN
         WRITE(IOIMP,*) 'Err. nb. noeud.'
         GOTO 9999
      ENDIF
      IF (NDIML2.NE.1) THEN
         WRITE(IOIMP,*) 'On veut la règle 2 sur un segment'
         GOTO 9999
      ENDIF
      IBPGC=0
      DO 1 IBPG2=1,NBPG2
         DO 12 IBPG1=1,NBPG1
            IBPGC=IBPGC+1
            IDIMLC=0
            DO 122 IDIML1=1,NDIML1
               IDIMLC=IDIMLC+1
               PGCOUR.XCOPG(IDIMLC,IBPGC)=
     $              PGPRO1.XCOPG(IDIML1,IBPG1)
     $              *(1.D0-PGPRO2.XCOPG(1,IBPG2))
 122        CONTINUE
            IDIMLC=IDIMLC+1
            PGCOUR.XCOPG(IDIMLC,IBPGC)=
     $           PGPRO2.XCOPG(1,IBPG2)
 124        CONTINUE
            PGCOUR.XPOPG(IBPGC)=PGPRO1.XPOPG(IBPG1)
     $           *PGPRO2.XPOPG(IBPG2)
 12      CONTINUE
 1    CONTINUE
      SEGDES PGPRO2
      SEGDES PGPRO1
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine cpropg'
      RETURN
*
* End of subroutine CPROPG
*
      END