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   26/01/09    21:15:56     12441          
  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. *
  63. * Executable statements
  64. *
  65.       WRITE(IOIMP,*) 'Entrée dans tesja2'
  66. *
  67. * On teste sur un segment à deux noeuds (D&T p.96)
  68. * avec six points de Gauss (sens direct et indirect pour le segment).
  69. * Dimension des espaces de référence et réels : 1, 1
  70. *
  71.       CALL FILRF('H1D1SE2',MYLRFS,MYLRF,IMPR,IRET)
  72.       IF (IRET.NE.0) GOTO 9999
  73.       CALL FIPG('GAC1-11-6',MYPGS,MYPG,IMPR,IRET)
  74.       IF (IRET.NE.0) GOTO 9999
  75.       CALL KFNREF(MYLRF,MYPG,FFGPG,DFFGPG,IMPR,IRET)
  76.       IF (IRET.NE.0) GOTO 9999
  77.       DO 3 INBTES=1,2
  78.          IF (INBTES.EQ.1) THEN
  79.             X1=-2.D0*XPI
  80.             X2=XPI
  81.          ELSEIF (INBTES.EQ.2) THEN
  82.             X1=3.D0*XPI
  83.             X2=-XPI
  84.          ELSE
  85.             WRITE(IOIMP,*) 'Erreur dans le nombre de tests'
  86.             GOTO 9999
  87.          ENDIF
  88.          NBELM=1
  89.          NBPOI=1
  90.          N2COL=1
  91.          N2LIG=1
  92.          NBCOL=2
  93.          NBLIG=1
  94.          SEGINI JCOOR
  95.          JCOOR.WELCHE(1,1,1,1,1,1)=X1
  96.          JCOOR.WELCHE(1,2,1,1,1,1)=X2
  97. *     Echelle de valeurs pour les coordonnées
  98.          XYMAX=XZERO
  99.          do ibelm=1,nbelm
  100.             do ibpoi=1,nbpoi
  101.                do i2col=1,n2col
  102.                   do i2lig=1,n2lig
  103.                      do ibcol=1,nbcol
  104.                         do iblig=1,nblig
  105.                            XYMAX=MAX(abs(jcoor.welche(iblig,ibcol,i2lig
  106.      $                          ,i2col,ibpoi,ibelm)),xymax)
  107.                         enddo
  108.                      enddo
  109.                   enddo
  110.                enddo
  111.             enddo
  112.          enddo
  113.          xtprec=max(XYMAX*xzprec,sqrt(xpetit))
  114.          IF (IMPR.GT.3) THEN
  115.             WRITE(IOIMP,*) 'JCOOR'
  116.             CALL PRCHVA(JCOOR,IMPR,IRET)
  117.             IF (IRET.NE.0) GOTO 9999
  118.          ENDIF
  119.          CALL GEOLIN(DFFGPG,JCOOR,NBELM,
  120.      $        JMAJAC,JMIJAC,JDTJAC,
  121.      $        IMPR,IRET)
  122.          IF (IRET.NE.0) GOTO 9999
  123. *
  124. *     Test sur les valeurs de la matrice jacobienne, de son inverse
  125. *     et de son déterminant aux points de Gauss...
  126. *
  127.          SEGACT JMAJAC
  128.          SEGACT JMIJAC
  129.          SEGACT JDTJAC
  130.          L=(X2-X1)
  131.          JXX(1,1)=L/2.D0
  132.          JIXX(1,1)=2.D0/L
  133.          DETJXX=L/2.D0
  134.          DO INPG=1,JMAJAC.WELCHE(/5)
  135.             JXXA=JMAJAC.WELCHE(1,1,1,1,INPG,1)
  136.             XERR=ABS(JXX(1,1)-JXXA)
  137.             IF (XERR.GT.XTPREC) THEN
  138.                WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
  139.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  140.                WRITE(IOIMP,*) 'JXX=',JXX(1,1)
  141.                WRITE(IOIMP,*) 'JXXA=',JXXA
  142.                GOTO 9999
  143.             ENDIF
  144.          ENDDO
  145.          DO INPG=1,JMIJAC.WELCHE(/5)
  146.             JIXXA=JMIJAC.WELCHE(1,1,1,1,INPG,1)
  147.             XERR=ABS(JIXX(1,1)-JIXXA)
  148.             IF (XERR.GT.XTPREC) THEN
  149.                WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
  150.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  151.                WRITE(IOIMP,*) 'JIXX=',JIXX(1,1)
  152.                WRITE(IOIMP,*) 'JIXXA=',JIXXA
  153.                GOTO 9999
  154.             ENDIF
  155.          ENDDO
  156.          DO INPG=1,JDTJAC.WELCHE(/5)
  157.             DETA=JDTJAC.WELCHE(1,1,1,1,INPG,1)
  158.             XERR=ABS(DETJXX-DETA)
  159.             IF (XERR.GT.XTPREC) THEN
  160.                WRITE(IOIMP,*) 'Erreur calcul det. mat. jac.'
  161.                WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  162.                WRITE(IOIMP,*) 'DETJXX=',DETJXX
  163.                WRITE(IOIMP,*) 'DETA=',DETA
  164.                GOTO 9999
  165.             ENDIF
  166.          ENDDO
  167.          SEGDES JDTJAC
  168.          SEGDES JMIJAC
  169.          SEGDES JMAJAC
  170.          IF (IMPR.GT.3) THEN
  171.             WRITE(IOIMP,*) 'JMAJAC'
  172.             CALL PRCHVA(JMAJAC,IMPR,IRET)
  173.             IF (IRET.NE.0) GOTO 9999
  174.             WRITE(IOIMP,*) 'JMIJAC'
  175.             CALL PRCHVA(JMIJAC,IMPR,IRET)
  176.             IF (IRET.NE.0) GOTO 9999
  177.             WRITE(IOIMP,*) 'JDTJAC'
  178.             CALL PRCHVA(JDTJAC,IMPR,IRET)
  179.             IF (IRET.NE.0) GOTO 9999
  180.          ENDIF
  181.          WRITE(IOIMP,*) 'Test',INBTES,' successful'
  182.  3    CONTINUE
  183. *
  184. * Normal termination
  185. *
  186.       IRET=0
  187.       RETURN
  188. *
  189. * Format handling
  190. *
  191. *
  192. * Error handling
  193. *
  194.  9999 CONTINUE
  195.       IRET=1
  196.       WRITE(IOIMP,*) 'An error was detected in subroutine tesja2'
  197.       RETURN
  198. *
  199. * End of subroutine tesja2
  200. *
  201.       END
  202.  
  203.  

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