Télécharger la plaquette Cast3M


fr en

Télécharger tesja1.eso

Retour à la liste

Numérotation des lignes : 

tesja1

  1. C TESJA1    SOURCE    GOUNAND   23/07/31    21:15:03     11713          
  2.       SUBROUTINE TESJA1(MYLRFS,MYPGS,
  3.      $     IMPR,IRET)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM         : TESJA1
  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 carré...
  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(2,2)
  59.       REAL*8 X1,X2,X3,X4
  60.       REAL*8 Y1,Y2,Y3,Y4
  61.       REAL*8 KSIPG,ETAPG,A0,A1,A2,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 tesja1'
  68. *
  69. * On teste sur un élément quadrilatéral à quatre noeuds (D&T p.54-55)
  70. * avec douze points de Gauss, dans le cas rectangulaire, et dans le cas
  71. * où l'élément est illicite (les côtés opposés se croisent).
  72. * Dimension des espaces de référence et réels : 2, 2
  73. *
  74. *
  75.       CALL FILRF('H1D1QU4',MYLRFS,MYLRF,IMPR,IRET)
  76.       IF (IRET.NE.0) GOTO 9999
  77.       CALL FIPG('GAC2-7-12A',MYPGS,MYPG,IMPR,IRET)
  78.       IF (IRET.NE.0) GOTO 9999
  79.       CALL KFNREF(MYLRF,MYPG,FFGPG,DFFGPG,IMPR,IRET)
  80.       IF (IRET.NE.0) GOTO 9999
  81.       DO 3 INBTES=1,3
  82.          IF (INBTES.EQ.1) THEN
  83.             X1=0.9D0
  84.             Y1=1.1D0
  85.             X2=1.75D0
  86.             Y2=2.25D0
  87.             X3=3.4D0
  88.             Y3=3.9D0
  89.             X4=2.1D0
  90.             Y4=6.2D0
  91.          ELSEIF (INBTES.EQ.2) THEN
  92.             X1=0.9D0
  93.             Y1=1.1D0
  94.             X2=1.75D0
  95.             Y2=Y1
  96.             X3=X2
  97.             Y3=3.9D0
  98.             X4=X1
  99.             Y4=Y3
  100.          ELSEIF (INBTES.EQ.3) THEN
  101.             X1=0.9D0
  102.             Y1=1.1D0
  103.             X3=1.75D0
  104.             Y3=2.25D0
  105.             X2=3.4D0
  106.             Y2=3.9D0
  107.             X4=2.1D0
  108.             Y4=6.2D0
  109.          ELSE
  110.             WRITE(IOIMP,*) 'Erreur dans le nombre de tests'
  111.             GOTO 9999
  112.          ENDIF
  113.          NBELM=1
  114.          NBPOI=1
  115.          N2COL=2
  116.          N2LIG=1
  117.          NBCOL=4
  118.          NBLIG=1
  119.          SEGINI JCOOR
  120.          JCOOR.WELCHE(1,1,1,1,1,1)=X1
  121.          JCOOR.WELCHE(1,1,1,2,1,1)=Y1
  122.          JCOOR.WELCHE(1,2,1,1,1,1)=X2
  123.          JCOOR.WELCHE(1,2,1,2,1,1)=Y2
  124.          JCOOR.WELCHE(1,3,1,1,1,1)=X3
  125.          JCOOR.WELCHE(1,3,1,2,1,1)=Y3
  126.          JCOOR.WELCHE(1,4,1,1,1,1)=X4
  127.          JCOOR.WELCHE(1,4,1,2,1,1)=Y4
  128. *     Echelle de valeurs pour les coordonnées
  129.          XYMAX=XZERO
  130.          do ibelm=1,nbelm
  131.             do ibpoi=1,nbpoi
  132.                do i2col=1,n2col
  133.                   do i2lig=1,n2lig
  134.                      do ibcol=1,nbcol
  135.                         do iblig=1,nblig
  136.                            XYMAX=MAX(abs(jcoor.welche(iblig,ibcol,i2lig
  137.      $                          ,i2col,ibpoi,ibelm)),xymax)
  138.                         enddo
  139.                      enddo
  140.                   enddo
  141.                enddo
  142.             enddo
  143.          enddo
  144.          xtprec=max(XYMAX*xzprec,sqrt(xpetit))
  145. *
  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 (INBTES.NE.3) THEN
  156.             IF (IRET.NE.0) GOTO 9999
  157. *
  158. *     Test sur les valeurs de la matrice jacobienne et de son
  159. *     déterminant aux points de Gauss...
  160. *
  161.             SEGACT MYPG
  162.             SEGACT JMAJAC
  163.             SEGACT JDTJAC
  164.             NPG=MYPG.XCOPG(/2)
  165.             DO 32 INPG=1,NPG
  166.                KSIPG=MYPG.XCOPG(1,INPG)
  167.                ETAPG=MYPG.XCOPG(2,INPG)
  168.                JXX(1,1)=0.25D0*((-X1+X2+X3-X4)
  169.      $              +(ETAPG*(X1-X2+X3-X4)))
  170.                JXX(1,2)=0.25D0*((-X1-X2+X3+X4)
  171.      $              +(KSIPG*(X1-X2+X3-X4)))
  172.                JXX(2,1)=0.25D0*((-Y1+Y2+Y3-Y4)
  173.      $              +(ETAPG*(Y1-Y2+Y3-Y4)))
  174.                JXX(2,2)=0.25D0*((-Y1-Y2+Y3+Y4)
  175.      $              +(KSIPG*(Y1-Y2+Y3-Y4)))
  176.                A0=0.125D0*(((Y4-Y2)*(X3-X1))
  177.      $              -((Y3-Y1)*(X4-X2)))
  178.                A1=0.125D0*(((Y3-Y4)*(X2-X1))
  179.      $              -((Y2-Y1)*(X3-X4)))
  180.                A2=0.125D0*(((Y4-Y1)*(X3-X2))
  181.      $              -((Y3-Y2)*(X4-X1)))
  182.                DETJXX=A0+(A1*KSIPG)+(A2*ETAPG)
  183.                DO 322 ILIG=1,2
  184.                   DO 3222 ICOL=1,2
  185.                      JXXA=JMAJAC.WELCHE(1,1,ILIG,ICOL,INPG,1)
  186.                      XERR=ABS(JXX(ILIG,ICOL)-JXXA)
  187.                      IF (XERR.GT.XTPREC) THEN
  188.                         WRITE(IOIMP,*) 'Erreur calcul mat. jac.'
  189.                         WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  190.                         WRITE(IOIMP,*) 'JXX=',JXX(ILIG,ICOL)
  191.                         WRITE(IOIMP,*) 'JXXA=',JXXA
  192.                         GOTO 9999
  193.                      ENDIF
  194.  3222             CONTINUE
  195.  322           CONTINUE
  196.                DETA=JDTJAC.WELCHE(1,1,1,1,INPG,1)
  197.                XERR=ABS(DETJXX-DETA)
  198.                IF (XERR.GT.XTPREC) THEN
  199.                   WRITE(IOIMP,*) 'Erreur calcul det. mat. jac.'
  200.                   WRITE(IOIMP,*) 'XERR=',XERR, ' XTPREC=',XTPREC
  201.                   WRITE(IOIMP,*) 'DETJXX=',DETJXX
  202.                   WRITE(IOIMP,*) 'DETA=',DETA
  203.                   GOTO 9999
  204.                ENDIF
  205.  32         CONTINUE
  206.             SEGDES MYPG
  207.             SEGDES JDTJAC
  208.             SEGDES JMAJAC
  209.             IF (IMPR.GT.3) THEN
  210.                WRITE(IOIMP,*) 'JMAJAC'
  211.                CALL PRCHVA(JMAJAC,IMPR,IRET)
  212.                IF (IRET.NE.0) GOTO 9999
  213.                WRITE(IOIMP,*) 'JMIJAC'
  214.                CALL PRCHVA(JMIJAC,IMPR,IRET)
  215.                IF (IRET.NE.0) GOTO 9999
  216.                WRITE(IOIMP,*) 'JDTJAC'
  217.                CALL PRCHVA(JDTJAC,IMPR,IRET)
  218.                IF (IRET.NE.0) GOTO 9999
  219.             ENDIF
  220.             WRITE(IOIMP,*) 'Test',INBTES,' successful'
  221.          ELSE
  222.             IF (IRET.EQ.0) THEN
  223.                WRITE(IOIMP,*) 'Le test aurait dû planter...'
  224.                GOTO 9999
  225.             ELSE
  226.                WRITE(IOIMP,*) 'Le test a planté comme prévu...'
  227.             ENDIF
  228.          ENDIF
  229.  3    CONTINUE
  230. *
  231. * Normal termination
  232. *
  233.       IRET=0
  234.       RETURN
  235. *
  236. * Format handling
  237. *
  238. *
  239. * Error handling
  240. *
  241.  9999 CONTINUE
  242.       IRET=1
  243.       WRITE(IOIMP,*) 'An error was detected in subroutine tesja1'
  244.       RETURN
  245. *
  246. * End of subroutine tesja1
  247. *
  248.       END
  249.  
  250.  

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