Sources Esope | Cast3M

reshpt
C RESHPT    SOURCE    PV        22/04/19    16:18:11     11344          
      SUBROUTINE RESHPT(NNNN,NBSH,IELE,MELE,NPINT,IPT,IRET)
C=======================================================
C
C     MET LES VALEURS DES FONCTIONS DE FORMES DANS SHPTOT
C      ET LES COORDOONEES REDUITES LES POIDS D INTEGRATION
C      DANS QSIGAU ETAGAU DZEGAU POIGAU  ; LE TOUT EST
C      MIS DANS LE POINTEUR MINTE SON POINTEUR EST IPT
C     NNN   =NOMBRE DE POINTS DE GAUSS
C     NBSH  =NOMBRE DE FONCTIONS D'INTERPOLATION
C     IELE  =NUMERO DE L ELEMENT DANS NOMS (VOIR CCGEOME )
C     MELE  =NUMERO DE L ELEMENT DANS NOMTP
C    NPINT=NOMBRE DE POINTS D'INTEGRATION DONS LE CAS DES
C          ELEMENTS COQUES INTEGRES
C     IPT   = POINTEUR  SUR MINTE
C     IRET=1  OU  0  SUIVANT QUE MINTE A ETE CREEE OU PAS
C
C     CETTE ROUTINE GERE LES MESSAGES D ERREURS
C     PROVENANT DE L INCOMPATIBILTE ENTRE NOMS
C     D ELEMENTS,NOMBRE DE POINTS DE GAUSS,ET FONCTIONS DE FORME
C
C=======================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCGEOME
-INC SMINTE
 
-INC PPARAM
-INC CCOPTIO
      SEGMENT SHXX 
       REAL*8 SHPXXX(6,NBB)
      ENDSEGMENT
      DIMENSION IMIPOR(5)
C
      DATA IMIPOR/4,8,14,23,16/
C
*      write(ioimp,*) 'reshpt: nnnn,nbsh,iele,mele,npint=',nnnn,nbsh,iele
*     $     ,mele,npint
      NPINT1=NPINT
      NNN=NNNN
      IRET=1
      NBBB=NBNNE(IELE)
      NBNO=NBSH
 
      IP1C=0
      IF (MELE.GE.195.and.mele.LE.257.AND.NPINT.EQ.1) THEN
        IP1C=1
        NPINT1=0
      ELSEIF (MELE.GE.195.and.mele.LE.257.AND.NPINT.EQ.2) THEN
        IP1C=2
        NPINT1=0
      ENDIF
*      WRITE(6,*)'IP1C=',IP1C
 
      CALL DONRED(NNN,IELE,MELE,NBNO,NPINT1,IPT1,IRT1)
      IF (IRT1.EQ.1) GOTO 10
C
C     MESSAGE D ERREUR  NBPGAU ET IELE NON COMPATIBLES POUR
C     L INSTANT
C
      MOTERR(1:4)=NOMS(IELE)
      INTERR(1)=NNN
      CALL ERREUR(67)
      IRET=0
      GOTO 666
  10  CONTINUE
      MINTE=IPT1
      SEGACT MINTE*MOD
C
      IA=SHPTOT(/1)
      CALL ZERO(SHPTOT(1,1,1),IA*NBNO*NNN,1)
      NBB=NBNO
      SEGINI SHXX
*
*  BOUCLE SUR LES POINTS
*
      DO 100 II=1,NNN
C     INSERER EVENTUELLEMENT UN INDICATEUR DE SUCCES
      XX=QSIGAU(II)
      YY=ETAGAU(II)
      ZZ=DZEGAU(II)
      IF(MELE.EQ.96) THEN
        CALL SHAP96(XX,YY,ZZ,IELE,SHPXXX,IRT2)
      ELSE IF(MELE.EQ.128) THEN
        CALL SHROT3(XX,YY,ZZ,IELE,SHPXXX,IRT2)
      ELSEIF ((MELE.GE.111).AND.(MELE.LE.122)) THEN
        CALL SHPOLY(XX,YY,ZZ,II,MELE,SHPXXX,IRT2)
      ELSEIF ((MELE.GE.223).AND.(MELE.LE.236).AND.(IP1C.EQ.0)) THEN
        CALL SHMACR(XX,YY,ZZ,MELE,SHPXXX,IRT2)
      ELSEIF ((MELE.GE.195.and.mele.LE.257).AND.(IP1C.EQ.1)) THEN
        CALL SHP1CE(XX,YY,ZZ,MELE,SHPXXX,IRT2)
      ELSEIF(MELE.EQ.260) then
        CALL shSHB8(XX,shpxxx)
        irt2=1
      ELSE
        CALL SHAPE(XX,YY,ZZ,IELE,SHPXXX,IRT2)
      ENDIF
C
C  TRAITEMENT SPECIAL MILIEU POREUX
C
      IF(MELE.GE.79.AND.MELE.LE.83) THEN
      CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-78),
     .           SHPXXX(1,NBBB+1),IRT2)
*
      ELSE IF(MELE.GE.173.AND.MELE.LE.177) THEN
      CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-172),
     .           SHPXXX(1,NBBB+1),IRT2)
*
      ELSE IF(MELE.GE.178.AND.MELE.LE.182) THEN
      CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-177),
     .           SHPXXX(1,NBBB+1),IRT2)
*
      ENDIF
C
      DO 200  NO=1,NBNO
        DO 201 ID=1,6
          SHPTOT(ID,NO,II)=SHPXXX(ID,NO)
 201    CONTINUE
 200  CONTINUE
 100  CONTINUE
C
C     ON CALCULE LES FONCTIONS D EXTRAPOLATIONS
C
      if( mele.ne.260) CALL EXTRAP(SHPTOT,NNN,NBBB,NBNO)
C
      SEGSUP SHXX
      IF (IRT2.EQ.1) GOTO 20
C
C     ERREUR LES FONCTIONS DE FORME PAS ENCORE IMPLEMENTEES
C
      MOTERR(1:4)=NOMS(IELE)
      CALL ERREUR(68)
      IRET=0
      SEGSUP MINTE
      GOTO 666
  20  IPT=IPT1
      SEGACT,MINTE*NOMOD
  666 CONTINUE
      END