Télécharger la plaquette Cast3M


fr en

Télécharger ccgime.eso

Retour à la liste

Numérotation des lignes : 

ccgime

  1. C CCGIME    SOURCE    GOUNAND   26/01/09    21:15:05     12441          
  2.       SUBROUTINE CCGIME(LCOF,NOMLOI,
  3.      $     FC,
  4.      $     IMPR,IRET)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.       IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM         : CCGIME
  9. C DESCRIPTION : Lois de comportement aux points de Gauss :
  10. C               Inverse de la métrique par rapport à un
  11. C               élément de référence régulier.
  12. C
  13. C LANGAGE     : ESOPE
  14. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C               mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES          :
  18. C APPELE PAR       :
  19. C***********************************************************************
  20. C ENTREES            :
  21. C ENTREES/SORTIES    :
  22. C SORTIES            : -
  23. C TRAVAIL            :
  24. C***********************************************************************
  25. C VERSION    : v1, 22/09/10, version initiale
  26. C HISTORIQUE : v1, 22/09/10, création
  27. C HISTORIQUE :
  28. C***********************************************************************
  29. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  30. C en cas de modification de ce sous-programme afin de faciliter
  31. C la maintenance !
  32. C***********************************************************************
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCREEL
  37. -INC TNLIN
  38. *-INC SMCHAEL
  39.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  40.       POINTEUR FC.MCHEVA
  41.       POINTEUR LCOF.LCHEVA
  42.       POINTEUR JMAJAC.MCHEVA
  43.       POINTEUR JMIJAC.MCHEVA
  44.       POINTEUR JDTJAC.MCHEVA
  45.       POINTEUR JMAREG.MCHEVA
  46.       CHARACTER*8 NOMLOI
  47.       INTEGER ICOF
  48. *
  49. -INC TMXMAT
  50. * Objets temporaires
  51.       POINTEUR JAC.MXMAT,JT.MXMAT,MJT.MXMAT
  52.       POINTEUR G.MXMAT,IG.MXMAT,H.MXMAT,HIG.MXMAT,IGHIG.MXMAT
  53.       POINTEUR ME.MXMAT
  54. *
  55.       SEGMENT MCOF
  56.       POINTEUR COEF(IDIM,IDIM).MCHEVA
  57.       ENDSEGMENT
  58. *
  59.       LOGICAL LBID
  60.       INTEGER LAXSP
  61.       REAL*8 DEUPI,XR
  62.       REAL*8 XL,XM
  63.       DIMENSION DETG(1)
  64. *
  65.       INTEGER IMPR,IRET
  66. *
  67. * Executable statements
  68. *
  69.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgime'
  70. C      IF (.NOT.(IDIM.EQ.1)) THEN
  71. C         WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  72. C         GOTO 9999
  73. C      ENDIF
  74.       NLFC=FC.WELCHE(/6)
  75.       NPFC=FC.WELCHE(/5)
  76.       ICOF=0
  77. *
  78.       ICOF=ICOF+1
  79.       JMAJAC=LCOF.LISCHE(ICOF)
  80.       NLJA=JMAJAC.WELCHE(/6)
  81.       NPJA=JMAJAC.WELCHE(/5)
  82.       IREF=JMAJAC.WELCHE(/4)
  83.       IREL=JMAJAC.WELCHE(/3)
  84. *
  85.       IF (IREL.NE.IDIM) THEN
  86.          WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  87.          GOTO 9999
  88.       ENDIF
  89. *
  90.       ICOF=ICOF+1
  91.       ICOF=ICOF+1
  92.       ICOF=ICOF+1
  93.       JMAREG=LCOF.LISCHE(ICOF)
  94.       NLJR=JMAREG.WELCHE(/6)
  95.       NPJR=JMAREG.WELCHE(/5)
  96.       I1  =JMAREG.WELCHE(/4)
  97.       I2  =JMAREG.WELCHE(/3)
  98.       IF ((NLJR.NE.1).OR.(NPJR.NE.1).OR.(I1.NE.IREF).OR.(I2.NE.IREF))
  99.      $     THEN
  100.          WRITE(IOIMP,*) 'Erreur dims JMAREG'
  101.          GOTO 9999
  102.       ENDIF
  103. *
  104. * Objets temporaires et à préconditionner
  105. *
  106.       LDIM1=IREL
  107.       LDIM2=IREF
  108.       SEGINI,JAC
  109.       LDIM1=IREF
  110.       LDIM2=IREL
  111.       SEGINI,JT
  112.       SEGINI,MJT
  113.       LDIM1=IREF
  114.       LDIM2=IREF
  115.       SEGINI,G
  116.       SEGINI,IG
  117.       SEGINI,H
  118.       SEGINI,HIG
  119.       SEGINI,IGHIG
  120.       LDIM1=IREL
  121.       LDIM2=IREL
  122.       SEGINI,ME
  123. *
  124. * Calcul de la métrique des éléments réguliers
  125. *
  126.       CALL MAMA(JMAREG.WELCHE,IREF,IREF,
  127.      $     'JTJ     ',H.XMAT,IREF,IREF,
  128.      $     IMPR,IRET)
  129.       IF (IRET.NE.0) GOTO 9999
  130. *      SEGPRT,H
  131. *
  132.       DO ILFC=1,NLFC
  133.          IF (NLJA.EQ.1) THEN
  134.             ILJA=1
  135.          ELSE
  136.             ILJA=ILFC
  137.          ENDIF
  138.          DO IPFC=1,NPFC
  139.             IF (NPJA.EQ.1) THEN
  140.                IPJA=1
  141.             ELSE
  142.                IPJA=IPFC
  143.             ENDIF
  144. *
  145. * Copie du jacobien
  146. *
  147.             CALL MAMA(JMAJAC.WELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  148.      $           'COPIE   ',
  149.      $           JAC.XMAT,IREL,IREF,
  150.      $           IMPR,IRET)
  151.             IF (IRET.NE.0) GOTO 9999
  152. *            SEGPRT,JAC
  153. *
  154. * Calcul de la métrique ME = J (JtJ)-1 h (JtJ)-1 Jt = J M Jt
  155. *
  156. *     Calcul de Jt
  157.             CALL MAMA(JAC.XMAT,IREL,IREF,
  158.      $           'TRANSPOS',JT.XMAT,IREF,IREL,
  159.      $           IMPR,IRET)
  160.             IF (IRET.NE.0) GOTO 9999
  161. *            SEGPRT,JT
  162. *     Calcul de G=JtJ
  163.             CALL MAMAMA(JT.XMAT,IREF,IREL,JAC.XMAT,IREL,IREF,
  164.      $           'FOIS    ',G.XMAT,IREF,IREF,
  165.      $           IMPR,IRET)
  166.             IF (IRET.NE.0) GOTO 9999
  167. *            SEGPRT,G
  168. * Calcul de l'inverse, du déterminant et trace de l'inverse de g
  169.             CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,
  170.      $           IMPR,IRET)
  171.             IF (IRET.NE.0) THEN
  172.                WRITE(IOIMP,*)
  173.      $              'JtJ non inversible'
  174.                SEGPRT,JAC
  175.                SEGPRT,G
  176.                GOTO 9999
  177.             ENDIF
  178. *            SEGPRT,IG
  179. * Calcul de hg-1, de sa trace et de son déterminant
  180.             CALL MAMAMA(H.XMAT,IREF,IREF,IG.XMAT,IREF,IREF,
  181.      $           'FOIS    ',HIG.XMAT,IREF,IREF,IMPR,IRET)
  182.             IF (IRET.NE.0) GOTO 9999
  183.             CALL MAMAMA(IG.XMAT,IREF,IREF,HIG.XMAT,IREF,IREF,
  184.      $           'FOIS    ',IGHIG.XMAT,IREF,IREF,IMPR,IRET)
  185.             IF (IRET.NE.0) GOTO 9999
  186.             CALL MAMAMA(IGHIG.XMAT,IREF,IREF,JT.XMAT,IREF,IREL,
  187.      $           'FOIS    ',MJT.XMAT,IREF,IREL,IMPR,IRET)
  188.             IF (IRET.NE.0) GOTO 9999
  189.             CALL MAMAMA(JAC.XMAT,IREL,IREF,MJT.XMAT,IREF,IREL,
  190.      $           'FOIS    ',ME.XMAT,IREL,IREL,IMPR,IRET)
  191.             IF (IRET.NE.0) GOTO 9999
  192. *
  193. * Calcul des la métrique inverse de l'élément
  194. *
  195.             IF (NOMLOI(1:4).EQ.'IMET') THEN
  196.                CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  197.                IF (IRET.NE.0) GOTO 9999
  198.                CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  199.                IF (IRET.NE.0) GOTO 9999
  200.                CONTRI=ME.XMAT(IDIM1,IDIM2)
  201. *               WRITE(IOIMP,*) 'CONTRI=',CONTRI
  202.             ELSE
  203.                WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  204.                WRITE(IOIMP,*) 'Erreur grave'
  205.                GOTO 9999
  206.             ENDIF
  207.             FC.WELCHE(1,1,1,1,IPFC,ILFC)=
  208.      $           FC.WELCHE(1,1,1,1,IPFC,ILFC)+
  209.      $           CONTRI
  210.          ENDDO
  211.       ENDDO
  212.       SEGSUP,ME
  213.       SEGSUP,IGHIG
  214.       SEGSUP,HIG
  215.       SEGSUP,H
  216.       SEGSUP,IG
  217.       SEGSUP,G
  218.       SEGSUP,MJT
  219.       SEGSUP,JT
  220.       SEGSUP,JAC
  221. *
  222. * Normal termination
  223. *
  224.       IRET=0
  225.       RETURN
  226. *
  227. * Format handling
  228. *
  229. *
  230. * Error handling
  231. *
  232.  9999 CONTINUE
  233.       IRET=1
  234.       WRITE(IOIMP,*) 'An error was detected in subroutine ccgime'
  235.       RETURN
  236. *
  237. * End of subroutine CCGIME
  238. *
  239.       END
  240.  
  241.  

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