Télécharger la plaquette Cast3M


fr en

Télécharger tesja2.eso

Retour à la liste

Numérotation des lignes : 

tesja2

  1. C TESJA2    SOURCE    GOUNAND   23/07/31    21:15:04     11713          
  2.       SUBROUTINE TESJA2(MYLRFS,MYPGS,
  3.      $     IMPR,IRET)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM         : TESJA2
  8. C PROJET      : Noyau linéaire NLIN
  9. C DESCRIPTION : On vérifie le calcul de la matrice jacobienne et de son
  10. C               déterminant sur un segment...
  11. C
  12. C LANGAGE     : ESOPE
  13. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  14. C               mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C APPELES          :
  17. C APPELES (E/S)    :
  18. C APPELES (BLAS)   :
  19. C APPELES (CALCUL) :
  20. C APPELE PAR       : TESTJA
  21. C***********************************************************************
  22. C SYNTAXE GIBIANE    :
  23. C ENTREES            :
  24. C ENTREES/SORTIES    :
  25. C SORTIES            :
  26. C***********************************************************************
  27. C VERSION    : v1, 16/08/99, version initiale
  28. C HISTORIQUE : v1, 16/08/99, création
  29. C HISTORIQUE :
  30. C HISTORIQUE :
  31. C***********************************************************************
  32. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33. C en cas de modification de ce sous-programme afin de faciliter
  34. C la maintenance !
  35. C***********************************************************************
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCREEL
  40. -INC TNLIN
  41. *-INC SELREF
  42.       POINTEUR MYLRFS.ELREFS
  43.       POINTEUR MYLRF.ELREF
  44. *-INC SPOGAU
  45.       POINTEUR MYPGS.POGAUS
  46.       POINTEUR MYPG.POGAU
  47. *-INC SMCHAEL
  48.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  49.       POINTEUR JCOOR.MCHEVA
  50.       POINTEUR JMAJAC.MCHEVA
  51.       POINTEUR JMIJAC.MCHEVA
  52.       POINTEUR JDTJAC.MCHEVA
  53.       POINTEUR FFGPG.MCHEVA
  54.       POINTEUR DFFGPG.MCHEVA
  55. *
  56.       INTEGER IMPR,IRET
  57. *
  58.       REAL*8 JXX(1,1),JIXX(1,1)
  59.       REAL*8 X1,X2
  60.       REAL*8 L,DETJXX,DETA,JXXA,JIXXA,XERR
  61.       INTEGER NPG,INPG,INBTES
  62.       LOGICAL LERJ
  63. *
  64. * Executable statements
  65. *
  66.       WRITE(IOIMP,*) 'Entrée dans tesja2'
  67. *
  68. * On teste sur un segment à deux noeuds (D&T p.96)
  69. * avec six points de Gauss (sens direct et indirect pour le segment).
  70. * Dimension des espaces de référence et réels : 1, 1
  71. *
  72.       CALL FILRF('H1D1SE2',MYLRFS,MYLRF,IMPR,IRET)
  73.       IF (IRET.NE.0) GOTO 9999
  74.       CALL FIPG('GAC1-11-6',MYPGS,MYPG,IMPR,IRET)
  75.       IF (IRET.NE.0) GOTO 9999
  76.       CALL KFNREF(MYLRF,MYPG,FFGPG,DFFGPG,IMPR,IRET)
  77.       IF (IRET.NE.0) GOTO 9999
  78.       DO 3 INBTES=1,2
  79.          IF (INBTES.EQ.1) THEN
  80.             X1=-2.D0*XPI
  81.             X2=XPI
  82.          ELSEIF (INBTES.EQ.2) THEN
  83.             X1=3.D0*XPI
  84.             X2=-XPI
  85.          ELSE
  86.             WRITE(IOIMP,*) 'Erreur dans le nombre de tests'
  87.             GOTO 9999
  88.          ENDIF
  89.          NBELM=1
  90.          NBPOI=1
  91.          N2COL=1
  92.          N2LIG=1
  93.          NBCOL=2
  94.          NBLIG=1
  95.          SEGINI JCOOR
  96.          JCOOR.WELCHE(1,1,1,1,1,1)=X1
  97.          JCOOR.WELCHE(1,2,1,1,1,1)=X2
  98. *     Echelle de valeurs pour les coordonnées
  99.          XYMAX=XZERO
  100.          do ibelm=1,nbelm
  101.             do ibpoi=1,nbpoi
  102.                do i2col=1,n2col
  103.                   do i2lig=1,n2lig
  104.                      do ibcol=1,nbcol
  105.                         do iblig=1,nblig
  106.                            XYMAX=MAX(abs(jcoor.welche(iblig,ibcol,i2lig
  107.      $                          ,i2col,ibpoi,ibelm)),xymax)
  108.                         enddo
  109.                      enddo
  110.                   enddo
  111.                enddo
  112.             enddo
  113.          enddo
  114.          xtprec=max(XYMAX*xzprec,sqrt(xpetit))
  115.          IF (IMPR.GT.3) THEN
  116.             WRITE(IOIMP,*) 'JCOOR'
  117.             CALL PRCHVA(JCOOR,IMPR,IRET)
  118.             IF (IRET.NE.0) GOTO 9999
  119.          ENDIF
  120.          LERJ=.FALSE.
  121.          CALL GEOLIN(DFFGPG,JCOOR,NBELM,
  122.      $        JMAJAC,JMIJAC,JDTJAC,LERJ,
  123.      $        IMPR,IRET)
  124.          IF (IRET.NE.0) GOTO 9999
  125. *
  126. *     Test sur les valeurs de la matrice jacobienne, de son inverse
  127. *     et de son déterminant aux points de Gauss...
  128. *
  129.          SEGACT JMAJAC
  130.          SEGACT JMIJAC
  131.          SEGACT JDTJAC
  132.          L=(X2-X1)
  133.          JXX(1,1)=L/2.D0
  134.          JIXX(1,1)=2.D0/L
  135.          DETJXX=L/2.D0
  136.          DO INPG=1,JMAJAC.WELCHE(/5)
  137.             JXXA=JMAJAC.WELCHE(1,1,1,1,INPG,1)
  138.             XERR=ABS(JXX(1,1)-JXXA)
  139.             IF (XERR.GT.XTPREC) THEN
  140.                WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
  141.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  142.                WRITE(IOIMP,*) 'JXX=',JXX(1,1)
  143.                WRITE(IOIMP,*) 'JXXA=',JXXA
  144.                GOTO 9999
  145.             ENDIF
  146.          ENDDO
  147.          DO INPG=1,JMIJAC.WELCHE(/5)
  148.             JIXXA=JMIJAC.WELCHE(1,1,1,1,INPG,1)
  149.             XERR=ABS(JIXX(1,1)-JIXXA)
  150.             IF (XERR.GT.XTPREC) THEN
  151.                WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
  152.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  153.                WRITE(IOIMP,*) 'JIXX=',JIXX(1,1)
  154.                WRITE(IOIMP,*) 'JIXXA=',JIXXA
  155.                GOTO 9999
  156.             ENDIF
  157.          ENDDO
  158.          DO INPG=1,JDTJAC.WELCHE(/5)
  159.             DETA=JDTJAC.WELCHE(1,1,1,1,INPG,1)
  160.             XERR=ABS(DETJXX-DETA)
  161.             IF (XERR.GT.XTPREC) THEN
  162.                WRITE(IOIMP,*) 'Erreur calcul det. mat. jac.'
  163.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  164.                WRITE(IOIMP,*) 'DETJXX=',DETJXX
  165.                WRITE(IOIMP,*) 'DETA=',DETA
  166.                GOTO 9999
  167.             ENDIF
  168.          ENDDO
  169.          SEGDES JDTJAC
  170.          SEGDES JMIJAC
  171.          SEGDES JMAJAC
  172.          IF (IMPR.GT.3) THEN
  173.             WRITE(IOIMP,*) 'JMAJAC'
  174.             CALL PRCHVA(JMAJAC,IMPR,IRET)
  175.             IF (IRET.NE.0) GOTO 9999
  176.             WRITE(IOIMP,*) 'JMIJAC'
  177.             CALL PRCHVA(JMIJAC,IMPR,IRET)
  178.             IF (IRET.NE.0) GOTO 9999
  179.             WRITE(IOIMP,*) 'JDTJAC'
  180.             CALL PRCHVA(JDTJAC,IMPR,IRET)
  181.             IF (IRET.NE.0) GOTO 9999
  182.          ENDIF
  183.          WRITE(IOIMP,*) 'Test',INBTES,' successful'
  184.  3    CONTINUE
  185. *
  186. * Normal termination
  187. *
  188.       IRET=0
  189.       RETURN
  190. *
  191. * Format handling
  192. *
  193. *
  194. * Error handling
  195. *
  196.  9999 CONTINUE
  197.       IRET=1
  198.       WRITE(IOIMP,*) 'An error was detected in subroutine tesja2'
  199.       RETURN
  200. *
  201. * End of subroutine tesja2
  202. *
  203.       END
  204.  
  205.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales