Télécharger la plaquette Cast3M


fr en

Télécharger geoli4.eso

Retour à la liste

Numérotation des lignes : 

geoli4

  1. C GEOLI4    SOURCE    GOUNAND   14/05/28    21:15:06     8056
  2.       SUBROUTINE GEOLI4(IESREL,IESREF,NDPOGO,NDELEM,JMAJAC,
  3.      $     JJTJ,JJTJM1,
  4.      $     JMIJAC,JDTJAC,LERJ,
  5.      $     IMPR,IRET)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.       IMPLICIT INTEGER (I-N)
  8. C***********************************************************************
  9. C NOM         : GEOLI4
  10. C PROJET      : Noyau linéaire NLIN
  11. C DESCRIPTION : Calcul du jacobien dans le cas où la matrice
  12. C               jacobienne A n'est pas carrée. A(n,m)
  13. C               On calcule sqrt (det (transpose(A) * A))
  14. C               Ceci est effectué pour chaque point de Gauss d'un
  15. C               élément.
  16. C               On calcule aussi le pseudo-inverse de J
  17. C
  18. C LANGAGE     : Fortran 77 (sauf E/S)
  19. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  20. C               mél : gounand@semt2.smts.cea.fr
  21. C***********************************************************************
  22. C APPELES          : -
  23. C APPELE PAR       : GEOLIN
  24. C***********************************************************************
  25. C ENTREES            : * IESREL (type entier) : dimension de l'espace
  26. C                        réel (i.e. géométrique).
  27. C                      * IESREF (type entier) : dimension de l'espace de
  28. C                        référence.
  29. C                      * NDNOEU (type entier) : nombre de ddl (par
  30. C                        élément) de la transformation géométrique.
  31. C                      * NDPOGO (type entier) : nombre de points
  32. C                        d'intégration.
  33. C                      * NDELEM (type entier) : nombre d'éléments du
  34. C                        maillage élémentaire courant.
  35. C                      * JMAJAC (type MCHEVA) : valeurs de la matrice
  36. C                        jacobienne aux points de Gauss sur le maillage
  37. C                        élémentaire courant.
  38. C ENTREES/SORTIES    : * JDTJAC (type MCHEVA) : valeurs de
  39. C                        sqrt(det(trans(J).J)) aux points de Gauss sur
  40. C                        le maillage élémentaire courant.
  41. C SORTIES            : -
  42. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  43. C***********************************************************************
  44. C VERSION    : v1, 26/10/06, version initiale
  45. C HISTORIQUE : v1, 26/10/06, création
  46. C HISTORIQUE :
  47. C HISTORIQUE :
  48. C***********************************************************************
  49. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  50. C en cas de modification de ce sous-programme afin de faciliter
  51. C la maintenance !
  52. C***********************************************************************
  53.  
  54. -INC PPARAM
  55. -INC CCOPTIO
  56.       INTEGER IESREF,IESREL,NDPOGO,NDELEM
  57.       REAL*8 JMAJAC(IESREL,IESREF,NDPOGO,NDELEM)
  58.       REAL*8 JMIJAC(IESREF,IESREL,NDPOGO,NDELEM)
  59.       REAL*8 JJTJ(IESREF,IESREF,NDPOGO,NDELEM)
  60.       REAL*8 JJTJM1(IESREF,IESREF,NDPOGO,NDELEM)
  61.       REAL*8 JDTJAC(NDPOGO,NDELEM)
  62. *
  63.       INTEGER IMPR,IRET
  64. *
  65.       INTEGER IELEM,IPOGO,IKF,IIF,IJL,IKL,IJF
  66.       LOGICAL LERJ
  67. *
  68. * Executable statements
  69. *
  70.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans geoli4'
  71. *
  72. * Calcul de JtJ
  73. *
  74.       DO IELEM=1,NDELEM
  75.          DO IPOGO=1,NDPOGO
  76.             DO IKF=1,IESREF
  77.                DO IIF=1,IESREF
  78.                   DO IJL=1,IESREL
  79.                      JJTJ(IIF,IKF,IPOGO,IELEM)=
  80.      $                    JJTJ(IIF,IKF,IPOGO,IELEM)+
  81.      $                    (JMAJAC(IJL,IIF,IPOGO,IELEM)
  82.      $                    *JMAJAC(IJL,IKF,IPOGO,IELEM))
  83.                   ENDDO
  84.                ENDDO
  85.             ENDDO
  86.          ENDDO
  87.       ENDDO
  88. *
  89. * Inverse et déterminant
  90. *
  91.       CALL GEOLI2(IESREF,NDPOGO,NDELEM,JJTJ,
  92.      $     JJTJM1,JDTJAC,LERJ,
  93.      $     IMPR,IRET)
  94.       IF (IRET.NE.0) THEN
  95.          IF (LERJ) THEN
  96.             WRITE(IOIMP,*) 'Erreur totalement anormale'
  97.          ENDIF
  98.          GOTO 9999
  99.       ENDIF
  100. *
  101. * Pseudo-inverse
  102. *
  103.       DO IELEM=1,NDELEM
  104.          DO IPOGO=1,NDPOGO
  105.             DO IKL=1,IESREL
  106.                DO IIF=1,IESREF
  107.                   DO IJF=1,IESREF
  108.                      JMIJAC(IIF,IKL,IPOGO,IELEM)=
  109.      $                    JMIJAC(IIF,IKL,IPOGO,IELEM)+
  110.      $                    (JJTJM1(IIF,IJF,IPOGO,IELEM)
  111.      $                    *JMAJAC(IKL,IJF,IPOGO,IELEM))
  112.                   ENDDO
  113.                ENDDO
  114.             ENDDO
  115.          ENDDO
  116.       ENDDO
  117. *
  118. * Racine du déterminant
  119. *
  120.       DO IELEM=1,NDELEM
  121.          DO IPOGO=1,NDPOGO
  122.             JDTJAC(IPOGO,IELEM)=SQRT(JDTJAC(IPOGO,IELEM))
  123.          ENDDO
  124.       ENDDO
  125. *
  126. * Normal termination
  127. *
  128.       IRET=0
  129.       RETURN
  130. *
  131. * Format handling
  132. *
  133. *
  134. * Error handling
  135. *
  136.  9998 CONTINUE
  137.       WRITE(IOIMP,*) 'Déterminant de la matrice tAA nul ou négatif'
  138.       WRITE(IOIMP,*) 'IELEM=',IELEM,' IPOGO=',IPOGO
  139.       GOTO 9999
  140.  9999 CONTINUE
  141.       IRET=1
  142.       WRITE(IOIMP,*) 'An error was detected in subroutine geoli4'
  143.       RETURN
  144. *
  145. * End of subroutine GEOLI4
  146. *
  147.       END
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  

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