Télécharger la plaquette Cast3M


fr en

Télécharger tesja4.eso

Retour à la liste

Numérotation des lignes : 

tesja4

  1. C TESJA4    SOURCE    GOUNAND   23/07/31    21:15:05     11713          
  2.       SUBROUTINE TESJA4(MYLRFS,MYPGS,
  3.      $     IMPR,IRET)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM         : TESJA4
  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 tétraèdre...
  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. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC CCREEL
  39. -INC TNLIN
  40. *-INC SELREF
  41.       POINTEUR MYLRFS.ELREFS
  42.       POINTEUR MYLRF.ELREF
  43. *-INC SPOGAU
  44.       POINTEUR MYPGS.POGAUS
  45.       POINTEUR MYPG.POGAU
  46. *-INC SMCHAEL
  47.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  48.       POINTEUR JCOOR.MCHEVA
  49.       POINTEUR JMAJAC.MCHEVA
  50.       POINTEUR JMIJAC.MCHEVA
  51.       POINTEUR JDTJAC.MCHEVA
  52.       POINTEUR FFGPG.MCHEVA
  53.       POINTEUR DFFGPG.MCHEVA
  54. *
  55.       INTEGER IMPR,IRET
  56. *
  57.       REAL*8 JXX(3,3)
  58.       REAL*8 X1,X2,X3,X4
  59.       REAL*8 Y1,Y2,Y3,Y4
  60.       REAL*8 Z1,Z2,Z3,Z4
  61.       REAL*8 DETJXX,DETA,JXXA,XERR
  62.       INTEGER NPG,INPG,ICOL,ILIG,INBTES
  63.       LOGICAL LERJ
  64. *
  65. * Executable statements
  66. *
  67.       WRITE(IOIMP,*) 'Entrée dans tesja4'
  68. *
  69. * On teste sur un tétraèdre à quatre noeuds (D&T p.131)
  70. * avec huit points de Gauss (sens direct et indirect pour le tétraèdre).
  71. * Dimension des espaces de référence et réels : 3, 3
  72. *
  73.       CALL FILRF('H1D1TE4',MYLRFS,MYLRF,IMPR,IRET)
  74.       IF (IRET.NE.0) GOTO 9999
  75.       CALL FIPG('GAT3-3-8B',MYPGS,MYPG,IMPR,IRET)
  76.       IF (IRET.NE.0) GOTO 9999
  77.       CALL KFNREF(MYLRF,MYPG,FFGPG,DFFGPG,IMPR,IRET)
  78.       IF (IRET.NE.0) GOTO 9999
  79.       DO 3 INBTES=1,2
  80.          IF (INBTES.EQ.1) THEN
  81.             X1=1.01D0
  82.             Y1=0.01D0
  83.             Z1=0.01D0
  84.             X2=0.02D0
  85.             Y2=0.02D0
  86.             Z2=1.02D0
  87.             X3=0.03D0
  88.             Y3=1.03D0
  89.             Z3=0.03D0
  90.             X4=0.02D0
  91.             Y4=0.02D0
  92.             Z4=0.02D0
  93.          ELSEIF (INBTES.EQ.2) THEN
  94.             X1=1.01D0
  95.             Y1=0.01D0
  96.             Z1=0.01D0
  97.             X3=0.02D0
  98.             Y3=0.02D0
  99.             Z3=1.02D0
  100.             X2=0.03D0
  101.             Y2=1.03D0
  102.             Z2=0.03D0
  103.             X4=0.02D0
  104.             Y4=0.02D0
  105.             Z4=0.02D0
  106.          ELSE
  107.             WRITE(IOIMP,*) 'Erreur dans le nombre de tests'
  108.             GOTO 9999
  109.          ENDIF
  110.          NBELM=1
  111.          NBPOI=1
  112.          N2COL=3
  113.          N2LIG=1
  114.          NBCOL=4
  115.          NBLIG=1
  116.          SEGINI JCOOR
  117.          JCOOR.WELCHE(1,1,1,1,1,1)=X1
  118.          JCOOR.WELCHE(1,1,1,2,1,1)=Y1
  119.          JCOOR.WELCHE(1,1,1,3,1,1)=Z1
  120.          JCOOR.WELCHE(1,2,1,1,1,1)=X2
  121.          JCOOR.WELCHE(1,2,1,2,1,1)=Y2
  122.          JCOOR.WELCHE(1,2,1,3,1,1)=Z2
  123.          JCOOR.WELCHE(1,3,1,1,1,1)=X3
  124.          JCOOR.WELCHE(1,3,1,2,1,1)=Y3
  125.          JCOOR.WELCHE(1,3,1,3,1,1)=Z3
  126.          JCOOR.WELCHE(1,4,1,1,1,1)=X4
  127.          JCOOR.WELCHE(1,4,1,2,1,1)=Y4
  128.          JCOOR.WELCHE(1,4,1,3,1,1)=Z4
  129. *     Echelle de valeurs pour les coordonnées
  130.          XYMAX=XZERO
  131.          do ibelm=1,nbelm
  132.             do ibpoi=1,nbpoi
  133.                do i2col=1,n2col
  134.                   do i2lig=1,n2lig
  135.                      do ibcol=1,nbcol
  136.                         do iblig=1,nblig
  137.                            XYMAX=MAX(abs(jcoor.welche(iblig,ibcol,i2lig
  138.      $                          ,i2col,ibpoi,ibelm)),xymax)
  139.                         enddo
  140.                      enddo
  141.                   enddo
  142.                enddo
  143.             enddo
  144.          enddo
  145.          xtprec=max(XYMAX*xzprec,sqrt(xpetit))
  146.          IF (IMPR.GT.3) THEN
  147.             WRITE(IOIMP,*) 'JCOOR'
  148.             CALL PRCHVA(JCOOR,IMPR,IRET)
  149.             IF (IRET.NE.0) GOTO 9999
  150.          ENDIF
  151.          LERJ=.FALSE.
  152.          CALL GEOLIN(DFFGPG,JCOOR,NBELM,
  153.      $        JMAJAC,JMIJAC,JDTJAC,LERJ,
  154.      $        IMPR,IRET)
  155.          IF (IRET.NE.0) GOTO 9999
  156. *
  157. *     Test sur les valeurs de la matrice jacobienne et de son
  158. *     déterminant aux points de Gauss...
  159. *
  160.          SEGACT MYPG
  161.          SEGACT JMAJAC
  162.          SEGACT JDTJAC
  163.          NPG=MYPG.XCOPG(/2)
  164.          JXX(1,1)=X2-X1
  165.          JXX(1,2)=X3-X1
  166.          JXX(1,3)=X4-X1
  167.          JXX(2,1)=Y2-Y1
  168.          JXX(2,2)=Y3-Y1
  169.          JXX(2,3)=Y4-Y1
  170.          JXX(3,1)=Z2-Z1
  171.          JXX(3,2)=Z3-Z1
  172.          JXX(3,3)=Z4-Z1
  173.          IF (INBTES.EQ.1) THEN
  174.             DETJXX=1.D0
  175.          ELSEIF (INBTES.EQ.2) THEN
  176.             DETJXX=-1.D0
  177.          ELSE
  178.             WRITE(IOIMP,*) 'Nb de test incorrect'
  179.             GOTO 9999
  180.          ENDIF
  181.          DO INPG=1,JMAJAC.WELCHE(/5)
  182.             DO 322 ILIG=1,3
  183.                DO 3222 ICOL=1,3
  184.                   JXXA=JMAJAC.WELCHE(1,1,ILIG,ICOL,INPG,1)
  185.                   XERR=ABS(JXX(ILIG,ICOL)-JXXA)
  186.                   IF (XERR.GT.XTPREC) THEN
  187.                      WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
  188.                      WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  189.                      WRITE(IOIMP,*) 'JXX=',JXX(ILIG,ICOL)
  190.                      WRITE(IOIMP,*) 'JXXA=',JXXA
  191.                      GOTO 9999
  192.                   ENDIF
  193.  3222          CONTINUE
  194.  322        CONTINUE
  195.          ENDDO
  196.          DO INPG=1,JDTJAC.WELCHE(/5)
  197.             DETA=JDTJAC.WELCHE(1,1,1,1,INPG,1)
  198.             XERR=ABS(DETJXX-DETA)
  199. *            IF (XERR.GT.0.1D0) THEN
  200.             IF (XERR.GT.XTPREC) THEN
  201.                WRITE(IOIMP,*) 'Erreur calcul det. mat. jac.'
  202.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  203.                WRITE(IOIMP,*) 'DETJXX=',DETJXX
  204.                WRITE(IOIMP,*) 'DETA=',DETA
  205.                GOTO 9999
  206.             ENDIF
  207.          ENDDO
  208.          SEGDES MYPG
  209.          SEGDES JDTJAC
  210.          SEGDES JMAJAC
  211.          IF (IMPR.GT.3) THEN
  212.             WRITE(IOIMP,*) 'JMAJAC'
  213.             CALL PRCHVA(JMAJAC,IMPR,IRET)
  214.             IF (IRET.NE.0) GOTO 9999
  215.             WRITE(IOIMP,*) 'JMIJAC'
  216.             CALL PRCHVA(JMIJAC,IMPR,IRET)
  217.             IF (IRET.NE.0) GOTO 9999
  218.             WRITE(IOIMP,*) 'JDTJAC'
  219.             CALL PRCHVA(JDTJAC,IMPR,IRET)
  220.             IF (IRET.NE.0) GOTO 9999
  221.          ENDIF
  222.          WRITE(IOIMP,*) 'Test',INBTES,' successful'
  223.  3    CONTINUE
  224. *
  225. * Normal termination
  226. *
  227.       IRET=0
  228.       RETURN
  229. *
  230. * Format handling
  231. *
  232. *
  233. * Error handling
  234. *
  235.  9999 CONTINUE
  236.       IRET=1
  237.       WRITE(IOIMP,*) 'An error was detected in subroutine tesja4'
  238.       RETURN
  239. *
  240. * End of subroutine tesja4
  241. *
  242.       END
  243.  
  244.  

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