Télécharger la plaquette Cast3M


fr en

Télécharger ccgqme.eso

Retour à la liste

Numérotation des lignes : 

ccgqme

  1. C CCGQME    SOURCE    PV        22/04/22    21:15:04     11344          
  2.       SUBROUTINE CCGQME(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         : CCGQME
  9. C DESCRIPTION : Lois de comportement aux points de Gauss :
  10. C               Qualité du maillage : alignement et isotropie
  11. C               cf. Huang
  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, 11/05/07, version initiale
  26. C HISTORIQUE : v1, 11/05/07, 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. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC CCREEL
  36. -INC TNLIN      
  37. *-INC SMCHAEL
  38.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  39.       POINTEUR FC.MCHEVA
  40.       POINTEUR LCOF.LCHEVA
  41.       POINTEUR JMAJAC.MCHEVA
  42.       POINTEUR JMIJAC.MCHEVA
  43.       POINTEUR JDTJAC.MCHEVA
  44.       POINTEUR JMAREG.MCHEVA
  45.       POINTEUR JMET.MCHEVA
  46.       POINTEUR JTHE.MCHEVA
  47.       POINTEUR JGAM.MCHEVA
  48.       CHARACTER*8 NOMLOI
  49.       INTEGER ICOF
  50. *
  51. -INC TMXMAT
  52. * Objets temporaires
  53.       POINTEUR JAC.MXMAT,JT.MXMAT
  54.       POINTEUR G.MXMAT,IG.MXMAT,H.MXMAT,HIG.MXMAT,GIH.MXMAT
  55.       POINTEUR ME.MXMAT,JTM.MXMAT,MJ.MXMAT
  56. *
  57.       SEGMENT MCOF
  58.       POINTEUR COEF(IDIM,IDIM).MCHEVA
  59.       ENDSEGMENT
  60.       POINTEUR MET.MCOF
  61. *
  62.       LOGICAL LBID
  63.       INTEGER LAXSP
  64.       REAL*8 DEUPI,XR
  65.       REAL*8 XL,XM
  66.       REAL*8 DETHIG(1,1),DETG(1,1)
  67. *
  68.       INTEGER IMPR,IRET
  69. *
  70. * Executable statements
  71. *
  72.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgqme'
  73. C      IF (.NOT.(IDIM.EQ.1)) THEN
  74. C         WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  75. C         GOTO 9999
  76. C      ENDIF
  77.       NLFC=FC.WELCHE(/6)
  78.       NPFC=FC.WELCHE(/5)
  79.       ICOF=0
  80. *
  81. *     Récupération des coefficients de la metrique
  82. *
  83.       SEGINI MET
  84.       DO IIDIM=1,IDIM
  85.          ICOF=ICOF+1
  86.          JMET=LCOF.LISCHE(ICOF)
  87.          IF (ICOF.EQ.1) THEN
  88.             NLJM=JMET.WELCHE(/6)
  89.             NPJM=JMET.WELCHE(/5)
  90.          ELSE
  91.             NLJM2=JMET.WELCHE(/6)
  92.             NPJM2=JMET.WELCHE(/5)
  93.             IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
  94.                WRITE(IOIMP,*) 'Erreur grave dims JMET'
  95.                GOTO 9999
  96.             ENDIF
  97.          ENDIF
  98.          MET.COEF(IIDIM,IIDIM)=JMET
  99.       ENDDO
  100.       DO IIDIM=1,IDIM
  101.          NJ=IDIM-IIDIM
  102.          IF (NJ.GE.1) THEN
  103.             DO JIDIM=IIDIM+1,IDIM
  104.                ICOF=ICOF+1
  105.                JMET=LCOF.LISCHE(ICOF)
  106.                NLJM2=JMET.WELCHE(/6)
  107.                NPJM2=JMET.WELCHE(/5)
  108.                IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
  109.                   WRITE(IOIMP,*) 'Erreur grave dims JMET2'
  110.                   GOTO 9999
  111.                ENDIF
  112.                MET.COEF(IIDIM,JIDIM)=JMET
  113.             ENDDO
  114.          ENDIF
  115.       ENDDO
  116. *
  117.       ICOF=ICOF+1
  118.       JMAJAC=LCOF.LISCHE(ICOF)
  119.       NLJA=JMAJAC.WELCHE(/6)
  120.       NPJA=JMAJAC.WELCHE(/5)
  121.       IREF=JMAJAC.WELCHE(/4)
  122.       IREL=JMAJAC.WELCHE(/3)
  123. *
  124.       IF (IREL.NE.IDIM) THEN
  125.          WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  126.          GOTO 9999
  127.       ENDIF
  128. *
  129.       ICOF=ICOF+1
  130.       ICOF=ICOF+1
  131.       ICOF=ICOF+1
  132.       JMAREG=LCOF.LISCHE(ICOF)
  133.       NLJR=JMAREG.WELCHE(/6)
  134.       NPJR=JMAREG.WELCHE(/5)
  135.       I1  =JMAREG.WELCHE(/4)
  136.       I2  =JMAREG.WELCHE(/3)
  137.       IF ((NLJR.NE.1).OR.(NPJR.NE.1).OR.(I1.NE.IREF).OR.(I2.NE.IREF))
  138.      $     THEN
  139.          WRITE(IOIMP,*) 'Erreur dims JMAREG'
  140.          GOTO 9999
  141.       ENDIF
  142. *
  143. * Objets temporaires et à préconditionner
  144. *
  145.       LDIM1=IREL
  146.       LDIM2=IREF
  147.       SEGINI,JAC
  148.       SEGINI,MJ
  149.       LDIM1=IREF
  150.       LDIM2=IREL
  151.       SEGINI,JT
  152.       SEGINI,JTM
  153.       LDIM1=IREF
  154.       LDIM2=IREF
  155.       SEGINI,G
  156.       SEGINI,IG
  157.       SEGINI,H
  158.       SEGINI,HIG
  159.       SEGINI,GIH
  160.       LDIM1=IREL
  161.       LDIM2=IREL
  162.       SEGINI,ME
  163. *
  164. * Calcul de la métrique des éléments réguliers
  165. *
  166.       CALL MAMA(JMAREG.WELCHE,IREF,IREF,
  167.      $     'JTJ     ',H.XMAT,IREF,IREF,
  168.      $     IMPR,IRET)
  169.       IF (IRET.NE.0) GOTO 9999
  170. *      SEGPRT,H
  171. *
  172.       DO ILFC=1,NLFC
  173.          IF (NLJM.EQ.1) THEN
  174.             ILJM=1
  175.          ELSE
  176.             ILJM=ILFC
  177.          ENDIF
  178.          IF (NLJA.EQ.1) THEN
  179.             ILJA=1
  180.          ELSE
  181.             ILJA=ILFC
  182.          ENDIF
  183.          DO IPFC=1,NPFC
  184.             IF (NPJM.EQ.1) THEN
  185.                IPJM=1
  186.             ELSE
  187.                IPJM=IPFC
  188.             ENDIF
  189.             IF (NPJA.EQ.1) THEN
  190.                IPJA=1
  191.             ELSE
  192.                IPJA=IPFC
  193.             ENDIF
  194. *
  195. * Copie des coefficients de la métrique
  196. *
  197.             DO IIDIM=1,IDIM
  198.                JMET=MET.COEF(IIDIM,IIDIM)
  199.                ME.XMAT(IIDIM,IIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
  200.             ENDDO
  201.             DO IIDIM=1,IIDIM
  202.                NJ=IDIM-IIDIM
  203.                IF (NJ.GE.1) THEN
  204.                   DO JIDIM=IIDIM+1,IDIM
  205.                      JMET=MET.COEF(IIDIM,JIDIM)
  206.                      ME.XMAT(IIDIM,JIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
  207.                      ME.XMAT(JIDIM,IIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
  208.                   ENDDO
  209.                ENDIF
  210.             ENDDO
  211. *
  212. * Copie du jacobien
  213. *
  214.             CALL MAMA(JMAJAC.WELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  215.      $           'COPIE   ',
  216.      $           JAC.XMAT,IREL,IREF,
  217.      $           IMPR,IRET)
  218.             IF (IRET.NE.0) GOTO 9999
  219. *            SEGPRT,JAC
  220. *
  221. * Calcul de la métrique G
  222. *
  223. *     Calcul de Jt
  224.             CALL MAMA(JAC.XMAT,IREL,IREF,
  225.      $           'TRANSPOS',JT.XMAT,IREF,IREL,
  226.      $           IMPR,IRET)
  227.             IF (IRET.NE.0) GOTO 9999
  228. *     Calcul de MJ
  229.             CALL MAMAMA(ME.XMAT,IREL,IREL,JAC.XMAT,IREL,IREF,
  230.      $           'FOIS    ',MJ.XMAT,IREL,IREF,
  231.      $           IMPR,IRET)
  232.             IF (IRET.NE.0) GOTO 9999
  233. *     Calcul de JTM
  234.             CALL MAMA(MJ.XMAT,IREL,IREF,
  235.      $           'TRANSPOS',JTM.XMAT,IREF,IREL,
  236.      $           IMPR,IRET)
  237.             IF (IRET.NE.0) GOTO 9999
  238. *     Calcul de G=JtMJ
  239.             CALL MAMAMA(JT.XMAT,IREF,IREL,MJ.XMAT,IREL,IREF,
  240.      $           'FOIS    ',G.XMAT,IREF,IREF,
  241.      $           IMPR,IRET)
  242.             IF (IRET.NE.0) GOTO 9999
  243. * Calcul de l'inverse, du déterminant et trace de l'inverse de g
  244.             LBID=.FALSE.
  245.             CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,LBID,IMPR,IRET)
  246.             IF (IRET.NE.0) GOTO 9999
  247. * Calcul de hg-1, de sa trace et de son déterminant
  248.             CALL MAMAMA(H.XMAT,IREF,IREF,IG.XMAT,IREF,IREF,
  249.      $           'FOIS    ',HIG.XMAT,IREF,IREF,IMPR,IRET)
  250.             IF (IRET.NE.0) GOTO 9999
  251.             LBID=.FALSE.
  252.             CALL GEOLI2(IREF,1,1,HIG.XMAT,GIH.XMAT,DETHIG,
  253.      $           LBID,IMPR,IRET)
  254.             IF (IRET.NE.0) GOTO 9999
  255.             XM=1.D0/SQRT(DETHIG(1,1))
  256.             CALL MARE(GIH.XMAT,IREF,IREF,'TRACE   ',
  257.      $           XL,IMPR,IRET)
  258.             IF (IRET.NE.0) GOTO 9999
  259. *
  260. * Calcul des qualités de maillage
  261. *
  262.             IF (NOMLOI.EQ.'QEQU    ') THEN
  263.                CONTRI=XM
  264.             ELSEIF (NOMLOI.EQ.'QALI') THEN
  265.                IF (IREF.EQ.1) THEN
  266.                   CONTRI=1.D0
  267.                ELSE
  268.                   XIREF=DBLE(IREF)
  269.                   XNUM=XL
  270.                   XDEN=XIREF*(XM**(2.D0/XIREF))
  271.                   XEXP=XIREF/(2.D0*(XIREF-1.D0))
  272.                   CONTRI=(XNUM/XDEN)**XEXP
  273. C                  SEGPRT,GIH
  274. C                  WRITE(IOIMP,*) 'TRGIH =',XL
  275. C                  WRITE(IOIMP,*) 'DETGIH=',(1.D0/DETHIG)
  276. C                  WRITE(IOIMP,*) 'XNUM=',XNUM
  277. C                  WRITE(IOIMP,*) 'XDEN=',XDEN
  278.                ENDIF
  279.             ELSE
  280.                WRITE(IOIMP,*) 'Erreur grave'
  281.                GOTO 9999
  282.             ENDIF
  283.             FC.WELCHE(1,1,1,1,IPFC,ILFC)=
  284.      $           FC.WELCHE(1,1,1,1,IPFC,ILFC)+
  285.      $           CONTRI
  286.          ENDDO
  287.       ENDDO
  288.       SEGSUP,ME
  289.       SEGSUP,GIH
  290.       SEGSUP,HIG
  291.       SEGSUP,H
  292.       SEGSUP,IG
  293.       SEGSUP,G
  294.       SEGSUP,JTM
  295.       SEGSUP,JT
  296.       SEGSUP,MJ
  297.       SEGSUP,JAC
  298.       SEGSUP,MET
  299. *
  300. * Normal termination
  301. *
  302.          IRET=0
  303.          RETURN
  304. *
  305. * Format handling
  306. *
  307. *
  308. * Error handling
  309. *
  310.  9999    CONTINUE
  311.          IRET=1
  312.          WRITE(IOIMP,*) 'An error was detected in subroutine ccgqme'
  313.          RETURN
  314. *
  315. * End of subroutine CCGQME
  316. *
  317.          END
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  

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