Télécharger la plaquette Cast3M


fr en

Télécharger ccgmtl.eso

Retour à la liste

Numérotation des lignes : 

ccgmtl

  1. C CCGMTL    SOURCE    GOUNAND   26/06/09    21:15:03     12566          
  2.       SUBROUTINE CCGMTL(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         : CCGMTL
  9. C DESCRIPTION : Lois de comportement aux points de Gauss :
  10. C      Métrique locale par rapport à un élément de référence
  11. C      régulier ponderee par une metrique globale M
  12. C
  13. C               (Copie de CCGMET et CCGAHU)
  14. C
  15. C LANGAGE     : ESOPE
  16. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C               mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES          :
  20. C APPELE PAR       :
  21. C***********************************************************************
  22. C ENTREES            :
  23. C ENTREES/SORTIES    :
  24. C SORTIES            : -
  25. C TRAVAIL            :
  26. C***********************************************************************
  27. C VERSION    : v1, 2026/04/14, version initiale
  28. C HISTORIQUE : v1, 2026/04/14, création
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  32. C en cas de modification de ce sous-programme afin de faciliter
  33. C la maintenance !
  34. C***********************************************************************
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC CCREEL
  39. -INC TNLIN
  40. *-INC SMCHAEL
  41.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  42.       POINTEUR FC.MCHEVA
  43.       POINTEUR LCOF.LCHEVA
  44.       POINTEUR JMAJAC.MCHEVA
  45.       POINTEUR JMIJAC.MCHEVA
  46.       POINTEUR JDTJAC.MCHEVA
  47.       POINTEUR JMET.MCHEVA
  48.       POINTEUR JMAREG.MCHEVA
  49.       CHARACTER*8 NOMLOI
  50.       INTEGER ICOF
  51. *
  52. -INC TMXMAT
  53. * Objets temporaires
  54.       POINTEUR JAC.MXMAT,J.MXMAT,MJ.MXMAT,JT.MXMAT
  55.       POINTEUR JR.MXMAT,IJR.MXMAT,G.MXMAT,IG.MXMAT,GTMP.MXMAT
  56.       POINTEUR M.MXMAT
  57. *
  58.       SEGMENT MCOF
  59.       POINTEUR COEF(IDIM,IDIM).MCHEVA
  60.       ENDSEGMENT
  61.       POINTEUR MET.MCOF
  62. *
  63.       INTEGER IMPR,IRET
  64. *
  65. * Executable statements
  66. *
  67.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgmtl'
  68. C      IF (.NOT.(IDIM.EQ.1)) THEN
  69. C         WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  70. C         GOTO 9999
  71. C      ENDIF
  72.       NLFC=FC.WELCHE(/6)
  73.       NPFC=FC.WELCHE(/5)
  74.       ICOF=0
  75. *
  76. *     Récupération des coefficients de la metrique
  77. *
  78.       SEGINI MET
  79.       DO IIDIM=1,IDIM
  80.          ICOF=ICOF+1
  81.          JMET=LCOF.LISCHE(ICOF)
  82.          IF (ICOF.EQ.1) THEN
  83.             NLJM=JMET.WELCHE(/6)
  84.             NPJM=JMET.WELCHE(/5)
  85.          ELSE
  86.             NLJM2=JMET.WELCHE(/6)
  87.             NPJM2=JMET.WELCHE(/5)
  88.             IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
  89.                WRITE(IOIMP,*) 'Erreur grave dims JMET'
  90.                GOTO 9999
  91.             ENDIF
  92.          ENDIF
  93.          MET.COEF(IIDIM,IIDIM)=JMET
  94.       ENDDO
  95.       DO IIDIM=1,IDIM
  96.          NJ=IDIM-IIDIM
  97.          IF (NJ.GE.1) THEN
  98.             DO JIDIM=IIDIM+1,IDIM
  99.                ICOF=ICOF+1
  100.                JMET=LCOF.LISCHE(ICOF)
  101.                NLJM2=JMET.WELCHE(/6)
  102.                NPJM2=JMET.WELCHE(/5)
  103.                IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
  104.                   WRITE(IOIMP,*) 'Erreur grave dims JMET2'
  105.                   GOTO 9999
  106.                ENDIF
  107.                MET.COEF(IIDIM,JIDIM)=JMET
  108.             ENDDO
  109.          ENDIF
  110.       ENDDO
  111. *
  112.       ICOF=ICOF+1
  113.       JMAJAC=LCOF.LISCHE(ICOF)
  114.       NLJA=JMAJAC.WELCHE(/6)
  115.       NPJA=JMAJAC.WELCHE(/5)
  116.       IREF=JMAJAC.WELCHE(/4)
  117.       IREL=JMAJAC.WELCHE(/3)
  118. *
  119.       IF (IREL.NE.IDIM) THEN
  120.          WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  121.          GOTO 9999
  122.       ENDIF
  123. *
  124.       ICOF=ICOF+1
  125.       ICOF=ICOF+1
  126.       ICOF=ICOF+1
  127.       JMAREG=LCOF.LISCHE(ICOF)
  128.       NLJR=JMAREG.WELCHE(/6)
  129.       NPJR=JMAREG.WELCHE(/5)
  130.       I1  =JMAREG.WELCHE(/4)
  131.       I2  =JMAREG.WELCHE(/3)
  132.       IF ((NLJR.NE.1).OR.(NPJR.NE.1).OR.(I1.NE.IREF).OR.(I2.NE.IREF))
  133.      $     THEN
  134.          WRITE(IOIMP,*) 'Erreur dims JMAREG'
  135.          GOTO 9999
  136.       ENDIF
  137. *
  138. * Objets temporaires et à préconditionner
  139. *
  140.       LDIM1=IREL
  141.       LDIM2=IREF
  142.       SEGINI,JAC
  143.       SEGINI,J
  144.       SEGINI,MJ
  145.       LDIM1=IREF
  146.       LDIM2=IREL
  147.       SEGINI,JT
  148.       LDIM1=IREF
  149.       LDIM2=IREF
  150.       SEGINI,JR
  151.       SEGINI,IJR
  152.       SEGINI,G
  153.       SEGINI,IG
  154. *      SEGINI,GTMP
  155.       LDIM1=IREL
  156.       LDIM2=IREL
  157.       SEGINI,M
  158. *
  159. * Calcul de la métrique des éléments réguliers
  160. *
  161.       CALL MAMA(JMAREG.WELCHE,IREF,IREF,
  162.      $     'COPIE   ',JR.XMAT,IREF,IREF,
  163.      $     IMPR,IRET)
  164.       IF (IRET.NE.0) GOTO 9999
  165. *      SEGPRT,JR
  166. * Calcul de l'inverse, du déterminant et trace de l'inverse de h
  167.       CALL GEOLI2(IREF,1,1,JR.XMAT,IJR.XMAT,DETJR,
  168.      $     IMPR,IRET)
  169.       IF (IRET.NE.0) THEN
  170.          WRITE(IOIMP,*)
  171.      $        'Jacobien des elements reguliers non inversible'
  172.          SEGPRT,JMAREG
  173.          SEGPRT,IJR
  174.          GOTO 9999
  175.       ENDIF
  176. *      SEGPRT,IJR
  177. *
  178.       DO ILFC=1,NLFC
  179.          IF (NLJM.EQ.1) THEN
  180.             ILJM=1
  181.          ELSE
  182.             ILJM=ILFC
  183.          ENDIF
  184.          IF (NLJA.EQ.1) THEN
  185.             ILJA=1
  186.          ELSE
  187.             ILJA=ILFC
  188.          ENDIF
  189.          DO IPFC=1,NPFC
  190.             IF (NPJM.EQ.1) THEN
  191.                IPJM=1
  192.             ELSE
  193.                IPJM=IPFC
  194.             ENDIF
  195.             IF (NPJA.EQ.1) THEN
  196.                IPJA=1
  197.             ELSE
  198.                IPJA=IPFC
  199.             ENDIF
  200. *
  201. * Copie des coefficients de la métrique
  202. *
  203.             DO IIDIM=1,IDIM
  204.                JMET=MET.COEF(IIDIM,IIDIM)
  205.                M.XMAT(IIDIM,IIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
  206.             ENDDO
  207.             DO IIDIM=1,IIDIM
  208.                NJ=IDIM-IIDIM
  209.                IF (NJ.GE.1) THEN
  210.                   DO JIDIM=IIDIM+1,IDIM
  211.                      JMET=MET.COEF(IIDIM,JIDIM)
  212.                      M.XMAT(IIDIM,JIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
  213.                      M.XMAT(JIDIM,IIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
  214.                   ENDDO
  215.                ENDIF
  216.             ENDDO
  217. *            SEGPRT,M
  218. *
  219. * Copie du jacobien
  220. *
  221.             CALL MAMA(JMAJAC.WELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  222.      $           'COPIE   ',
  223.      $           JAC.XMAT,IREL,IREF,
  224.      $           IMPR,IRET)
  225.             IF (IRET.NE.0) GOTO 9999
  226. *            SEGPRT,JAC
  227. *
  228. * Jacobien complet
  229. *
  230.             CALL MAMAMA(JAC.XMAT,IREL,IREF,IJR.XMAT,IREF,IREF,
  231.      $           'FOIS    ',J.XMAT,IREL,IREF,IMPR,IRET)
  232.             IF (IRET.NE.0) GOTO 9999
  233. *
  234. * Calcul de la métrique G = Jt M J
  235. *
  236. *     Calcul de Jt
  237.             CALL MAMA(J.XMAT,IREL,IREF,
  238.      $           'TRANSPOS',JT.XMAT,IREF,IREL,
  239.      $           IMPR,IRET)
  240.             IF (IRET.NE.0) GOTO 9999
  241. *            SEGPRT,JT
  242. *     Calcul de MJ
  243.             CALL MAMAMA(M.XMAT,IREL,IREL,J.XMAT,IREL,IREF,
  244.      $           'FOIS    ',MJ.XMAT,IREL,IREF,
  245.      $           IMPR,IRET)
  246.             IF (IRET.NE.0) GOTO 9999
  247. *     Calcul de G=JtMJ
  248.             CALL MAMAMA(JT.XMAT,IREF,IREL,MJ.XMAT,IREL,IREF,
  249.      $           'FOIS    ',G.XMAT,IREF,IREF,
  250.      $           IMPR,IRET)
  251.             IF (IRET.NE.0) GOTO 9999
  252. *            SEGPRT,G
  253.             CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,XM,IMPR,IRET)
  254.             IF (IRET.GT.0) GOTO 9999
  255. *            write(ioimp,*) 'In ccgmtl: JTMJ XM=',XM
  256.             XM=SQRT(MAX(XM,XZERO))
  257.             CALL MARE(G.XMAT,IREF,IREF,'TRACE   ',XL,IMPR,IRET)
  258.             IF (IRET.NE.0) GOTO 9999
  259. *            write(ioimp,*) 'In ccgmtl: JTMJ XL=',XL
  260.  
  261.             IF (IREF.EQ.IREL) THEN
  262. c$$$               CALL GEOLI2(IREF,1,1,JAC.XMAT,GTMP.XMAT,XDET,
  263. c$$$     $              IMPR,IRET)
  264. c$$$               IF (IRET.GT.0) GOTO 9999
  265. c$$$               CALL MARE(JAC.XMAT,IREF,IREF,'TRACE   ',
  266. c$$$     $              XTRA,IMPR,IRET)
  267. c$$$               IF (IRET.NE.0) GOTO 9999
  268. c$$$               write(ioimp,*) 'In ccgmtl: JAC XDET,XTRA=',XDET,XTRA
  269. c$$$               CALL GEOLI2(IREF,1,1,M.XMAT,GTMP.XMAT,XDET,
  270. c$$$     $              IMPR,IRET)
  271. c$$$               IF (IRET.GT.0) GOTO 9999
  272. c$$$               CALL MARE(M.XMAT,IREF,IREF,'TRACE   ',
  273. c$$$     $              XTRA,IMPR,IRET)
  274. c$$$               IF (IRET.NE.0) GOTO 9999
  275. c$$$               write(ioimp,*) 'In ccgmtl: MET XDET,XTRA=',XDET,XTRA
  276. c$$$               CALL GEOLI2(IREF,1,1,G.XMAT,GTMP.XMAT,XM,
  277. c$$$     $              IMPR,IRET)
  278. c$$$               IF (IRET.GT.0) GOTO 9999
  279. c$$$               CALL MARE(G.XMAT,IREF,IREF,'TRACE   ',
  280. c$$$     $              XL,IMPR,IRET)
  281. c$$$               IF (IRET.NE.0) GOTO 9999
  282. c$$$               write(ioimp,*) 'In ccgmtl: JTMJ XM,XL=',XM,XL
  283.             ENDIF
  284. *
  285. * Calcul des la métrique inverse de l'élément
  286. *
  287.             IF (NOMLOI(1:4).EQ.'METL') THEN
  288.                CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  289.                IF (IRET.NE.0) GOTO 9999
  290.                CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  291.                IF (IRET.NE.0) GOTO 9999
  292.                CONTRI=G.XMAT(IDIM1,IDIM2)
  293. *               WRITE(IOIMP,*) 'CONTRI=',CONTRI
  294.             ELSE
  295.                WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  296.                WRITE(IOIMP,*) 'Erreur grave'
  297.                GOTO 9999
  298.             ENDIF
  299.             FC.WELCHE(1,1,1,1,IPFC,ILFC)=
  300.      $           FC.WELCHE(1,1,1,1,IPFC,ILFC)+
  301.      $           CONTRI
  302.          ENDDO
  303.       ENDDO
  304.       SEGSUP,M
  305.       SEGSUP,G
  306.       SEGSUP,IJR
  307.       SEGSUP,JR
  308.       SEGSUP,JT
  309.       SEGSUP,MJ
  310.       SEGSUP,J
  311.       SEGSUP,JAC
  312.       SEGSUP,MET
  313. *
  314. * Normal termination
  315. *
  316.       IRET=0
  317.       RETURN
  318. *
  319. * Format handling
  320. *
  321. *
  322. * Error handling
  323. *
  324.  9999 CONTINUE
  325.       IRET=1
  326.       WRITE(IOIMP,*) 'An error was detected in subroutine ccgmtl'
  327.       RETURN
  328. *
  329. * End of subroutine CCGMTL
  330. *
  331.       END
  332.  
  333.  

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