C TESJA2    SOURCE    GOUNAND   05/12/21    21:37:08     5281           
      SUBROUTINE TESJA2(MYLRFS,MYPGS,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : TESJA2
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : On vérifie le calcul de la matrice jacobienne et de son
C               déterminant sur un segment...
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 APPELES (E/S)    :
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       : TESTJA
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            :
C***********************************************************************
C VERSION    : v1, 16/08/99, version initiale
C HISTORIQUE : v1, 16/08/99, 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
-INC CCREEL
CBEGININCLUDE SELREF
      SEGMENT ELREF
      CHARACTER*(LNNOM)  NOMLRF
      CHARACTER*(LNFORM) FORME 
      CHARACTER*(LNTYPL) TYPEL 
      CHARACTER*(LNESP)  ESPACE
      INTEGER DEGRE
      REAL*8 XCONOD(NDIMEL,NBNOD)
      INTEGER NPQUAF(NBDDL)
      INTEGER NUMCMP(NBDDL)
      INTEGER QUENOD(NBDDL)
      INTEGER ORDDER(NDIMEL,NBDDL)
      POINTEUR MBPOLY.POLYNS
      ENDSEGMENT
      SEGMENT ELREFS
      POINTEUR LISEL(0).ELREF
      ENDSEGMENT
CENDINCLUDE SELREF
      POINTEUR MYLRFS.ELREFS
      POINTEUR MYLRF.ELREF
CBEGININCLUDE SPOGAU
      SEGMENT POGAU
      CHARACTER*(LNNPG)  NOMPG
      CHARACTER*(LNTPG)  TYPMPG
      CHARACTER*(LNFPG)  FORLPG
      INTEGER NORDPG
      REAL*8 XCOPG(NDLPG,NBPG)
      REAL*8 XPOPG(NBPG)
      ENDSEGMENT
      SEGMENT POGAUS
      POINTEUR LISPG(0).POGAU
      ENDSEGMENT
CENDINCLUDE SPOGAU
      POINTEUR MYPGS.POGAUS
      POINTEUR MYPG.POGAU
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
      INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
      POINTEUR JCOOR.MCHEVA
      POINTEUR JMAJAC.MCHEVA
      POINTEUR JMIJAC.MCHEVA
      POINTEUR JDTJAC.MCHEVA
      POINTEUR FFGPG.MCHEVA
      POINTEUR DFFGPG.MCHEVA
*     
      INTEGER IMPR,IRET
*     
      REAL*8 JXX(1,1),JIXX(1,1)
      REAL*8 X1,X2
      REAL*8 L,DETJXX,DETA,JXXA,JIXXA,XERR
      REAL*8 XERREL
      INTEGER NPG,INPG,INBTES
      LOGICAL LERJ
*     
* Executable statements
*     
      WRITE(IOIMP,*) 'Entrée dans tesja2'
*
* On teste sur un segment à deux noeuds (D&T p.96)
* avec six points de Gauss (sens direct et indirect pour le segment). 
* Dimension des espaces de référence et réels : 1, 1
*
      CALL FILRF('H1D1SE2',MYLRFS,MYLRF,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      CALL FIPG('GAC1-11-6',MYPGS,MYPG,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      CALL KFNREF(MYLRF,MYPG,FFGPG,DFFGPG,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      DO 3 INBTES=1,2
         IF (INBTES.EQ.1) THEN
            X1=-2.D0*XPI
            X2=XPI
         ELSEIF (INBTES.EQ.2) THEN
            X1=3.D0*XPI
            X2=-XPI
         ELSE
            WRITE(IOIMP,*) 'Erreur dans le nombre de tests'
            GOTO 9999
         ENDIF
         NBELM=1
         NBPOI=1
         N2COL=1
         N2LIG=1
         NBCOL=2
         NBLIG=1
         SEGINI JCOOR
         JCOOR.VELCHE(1,1,1,1,1,1)=X1
         JCOOR.VELCHE(1,2,1,1,1,1)=X2
         SEGDES JCOOR
         IF (IMPR.GT.3) THEN
            WRITE(IOIMP,*) 'JCOOR'
            CALL PRCHVA(JCOOR,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
         ENDIF
         LERJ=.FALSE.
         CALL GEOLIN(DFFGPG,JCOOR,NBELM,
     $        JMAJAC,JMIJAC,JDTJAC,LERJ,
     $        IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
*     
*     Test sur les valeurs de la matrice jacobienne, de son inverse
*     et de son déterminant aux points de Gauss...
*     
         SEGACT JMAJAC
         SEGACT JMIJAC
         SEGACT JDTJAC
         L=(X2-X1)
         JXX(1,1)=L/2.D0
         JIXX(1,1)=2.D0/L
         DETJXX=L/2.D0
         DO INPG=1,JMAJAC.VELCHE(/5)
            JXXA=JMAJAC.VELCHE(1,1,1,1,INPG,1)
            XERR=XERREL(JXX(1,1),JXXA)
            IF (XERR.GT.10.D0*XZPREC) THEN
               WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
               WRITE(IOIMP,*) 'XERR=',XERR, ' XZPREC=',XZPREC
               WRITE(IOIMP,*) 'JXX=',JXX(1,1)
               WRITE(IOIMP,*) 'JXXA=',JXXA
               GOTO 9999
            ENDIF
         ENDDO
         DO INPG=1,JMIJAC.VELCHE(/5)
            JIXXA=JMIJAC.VELCHE(1,1,1,1,INPG,1)
            XERR=XERREL(JIXX(1,1),JIXXA)
            IF (XERR.GT.10.D0*XZPREC) THEN
               WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
               WRITE(IOIMP,*) 'XERR=',XERR, ' XZPREC=',XZPREC
               WRITE(IOIMP,*) 'JIXX=',JIXX(1,1)
               WRITE(IOIMP,*) 'JIXXA=',JIXXA
               GOTO 9999
            ENDIF
         ENDDO
         DO INPG=1,JDTJAC.VELCHE(/5)
            DETA=JDTJAC.VELCHE(1,1,1,1,INPG,1)
            XERR=XERREL(DETJXX,DETA)
            IF (XERR.GT.10.D0*XZPREC) THEN
               WRITE(IOIMP,*) 'Erreur calcul det. mat. jac.'
               WRITE(IOIMP,*) 'XERR=',XERR, ' XZPREC=',XZPREC
               WRITE(IOIMP,*) 'DETJXX=',DETJXX
               WRITE(IOIMP,*) 'DETA=',DETA
               GOTO 9999
            ENDIF
         ENDDO
         SEGDES JDTJAC
         SEGDES JMIJAC
         SEGDES JMAJAC
         IF (IMPR.GT.3) THEN
            WRITE(IOIMP,*) 'JMAJAC'
            CALL PRCHVA(JMAJAC,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            WRITE(IOIMP,*) 'JMIJAC'
            CALL PRCHVA(JMIJAC,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            WRITE(IOIMP,*) 'JDTJAC'
            CALL PRCHVA(JDTJAC,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
         ENDIF
         WRITE(IOIMP,*) 'Test',INBTES,' successful'
 3    CONTINUE
*     
* Normal termination
*     
      IRET=0
      RETURN
*     
* Format handling
*     
*     
* Error handling
*     
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine tesja2'
      RETURN
*     
* End of subroutine tesja2
*     
      END