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    PV        22/04/22    21:15:03     11344          
  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.             LBID=.FALSE.
  170.             CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,
  171.      $           LBID,IMPR,IRET)
  172.             IF (IRET.NE.0) GOTO 9999
  173. *            SEGPRT,IG
  174. * Calcul de hg-1, de sa trace et de son déterminant
  175.             CALL MAMAMA(H.XMAT,IREF,IREF,IG.XMAT,IREF,IREF,
  176.      $           'FOIS    ',HIG.XMAT,IREF,IREF,IMPR,IRET)
  177.             IF (IRET.NE.0) GOTO 9999
  178.             CALL MAMAMA(IG.XMAT,IREF,IREF,HIG.XMAT,IREF,IREF,
  179.      $           'FOIS    ',IGHIG.XMAT,IREF,IREF,IMPR,IRET)
  180.             IF (IRET.NE.0) GOTO 9999
  181.             CALL MAMAMA(IGHIG.XMAT,IREF,IREF,JT.XMAT,IREF,IREL,
  182.      $           'FOIS    ',MJT.XMAT,IREF,IREL,IMPR,IRET)
  183.             IF (IRET.NE.0) GOTO 9999
  184.             CALL MAMAMA(JAC.XMAT,IREL,IREF,MJT.XMAT,IREF,IREL,
  185.      $           'FOIS    ',ME.XMAT,IREL,IREL,IMPR,IRET)
  186.             IF (IRET.NE.0) GOTO 9999
  187. *
  188. * Calcul des la métrique inverse de l'élément
  189. *
  190.             IF (NOMLOI(1:4).EQ.'IMET') THEN
  191.                CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  192.                IF (IRET.NE.0) GOTO 9999
  193.                CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  194.                IF (IRET.NE.0) GOTO 9999
  195.                CONTRI=ME.XMAT(IDIM1,IDIM2)
  196. *               WRITE(IOIMP,*) 'CONTRI=',CONTRI
  197.             ELSE
  198.                WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  199.                WRITE(IOIMP,*) 'Erreur grave'
  200.                GOTO 9999
  201.             ENDIF
  202.             FC.WELCHE(1,1,1,1,IPFC,ILFC)=
  203.      $           FC.WELCHE(1,1,1,1,IPFC,ILFC)+
  204.      $           CONTRI
  205.          ENDDO
  206.       ENDDO
  207.       SEGSUP,ME
  208.       SEGSUP,IGHIG
  209.       SEGSUP,HIG
  210.       SEGSUP,H
  211.       SEGSUP,IG
  212.       SEGSUP,G
  213.       SEGSUP,MJT
  214.       SEGSUP,JT
  215.       SEGSUP,JAC
  216. *
  217. * Normal termination
  218. *
  219.       IRET=0
  220.       RETURN
  221. *
  222. * Format handling
  223. *
  224. *
  225. * Error handling
  226. *
  227.  9999 CONTINUE
  228.       IRET=1
  229.       WRITE(IOIMP,*) 'An error was detected in subroutine ccgime'
  230.       RETURN
  231. *
  232. * End of subroutine CCGIME
  233. *
  234.       END
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  

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