Télécharger la plaquette Cast3M


fr en

Télécharger tesja5.eso

Retour à la liste

Numérotation des lignes : 

tesja5

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

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