Télécharger la plaquette Cast3M


fr en

Télécharger quali7.eso

Retour à la liste

Numérotation des lignes : 

quali7

  1. C QUALI7    SOURCE    GOUNAND   25/11/21    21:15:04     12404          
  2.       SUBROUTINE QUALI7(ITOPO,IMET,IMOMET,XDENS,ICMETR,XVTOL,
  3.      $     MLREEL,IMPR,IVERI)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM         : QUALI7
  8. C DESCRIPTION : Interface à QUALI6 pour calculer les qualités des
  9. C     éléments
  10. C
  11. C
  12. C     La programmation est reprise de optt1.eso
  13. C
  14. C
  15. C LANGAGE     : ESOPE
  16. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  17. C               mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES          :
  20. C APPELES (E/S)    :
  21. C APPELES (BLAS)   :
  22. C APPELES (CALCUL) :
  23. C APPELE PAR       :
  24. C***********************************************************************
  25. C SYNTAXE GIBIANE    :
  26. C ENTREES            :
  27. C ENTREES/SORTIES    :
  28. C SORTIES            :
  29. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  30. C***********************************************************************
  31. C VERSION    : v1, 01/12/2017, version initiale
  32. C HISTORIQUE : v1, 01/12/2017, création
  33. C HISTORIQUE :
  34. C HISTORIQUE :
  35. C***********************************************************************
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. *-INC TMATOP2
  39. -INC SMELEME
  40. * Numerotation globale
  41.       POINTEUR ITOPO.MELEME
  42. *     Numerotation locale
  43. -INC TMATOP1
  44. *-INC SMELEMX
  45.       POINTEUR KTOPO.MELEMX
  46. -INC SMCHPOI
  47.       POINTEUR ICMETR.MCHPOI
  48. *-INC SMETRIQ
  49.       POINTEUR KCMETR.METRIQ
  50. -INC SMCOORD
  51. * Numerotation globale
  52.       POINTEUR ICOORD.MCOORD
  53. ** Numerotation locale
  54.       POINTEUR KCOORD.MCOORD
  55. *-INC TMTRAV
  56.       SEGMENT MISDEF
  57.       INTEGER ISDEF(NNIN,NNNOE)
  58.       ENDSEGMENT
  59. *-INC STRAVJ
  60. -INC SMLMOTS
  61.       POINTEUR KNMETR.MLMOTS
  62. -INC SMLREEL
  63. *
  64. * Passage de numerotation globale -> locale
  65. *   et locale -> globale
  66.       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  67.       SEGMENT IDCP(NPTINI)
  68.       integer oooval
  69.       CHARACTER*4 MOT
  70.       INTEGER IMPR,IRET
  71. * Noms de composantes pour la métrique
  72.  
  73. *
  74. * Executable statements
  75. *
  76.       IF (IMPR.GE.5) WRITE(IOIMP,*) 'Entrée dans quali7.eso'
  77.       IDIMP=IDIM+1
  78.       ICOORD=MCOORD
  79.       SEGACT MCOORD
  80. *      write(ioimp,*) 'quali7 debut : nbpts, xcoor,idim=',
  81. *     $     nbpts,xcoor(/1)/(idim+1),idim
  82.       IBPTS=NBPTS
  83. *     On se simplifie la vie en ne considérant que des maillages simples
  84. *      call ecmai1(itopo,0)
  85.       SEGACT ITOPO
  86.       NBSOUS=ITOPO.LISOUS(/1)
  87.       NBNN=ITOPO.NUM(/1)
  88.       IF (NBSOUS.NE.0.OR.NBNN.NE.IDIMP) THEN
  89.          WRITE(IOIMP,*)
  90.      $        'Topologie : pas un maillage de simplex volumiques'
  91.          GOTO 9999
  92.       ENDIF
  93. * Correspondances de numérotation
  94.       SEGINI ICPR
  95.       IK=0
  96.       DO 23 IEL=1,ITOPO.NUM(/2)
  97.          DO 230 INO=1,ITOPO.NUM(/1)
  98.             IP=ITOPO.NUM(INO,IEL)
  99.             IF (ICPR(IP).EQ.0) THEN
  100.                IK=IK+1
  101.                ICPR(IP)=IK
  102.             ENDIF
  103.  230     CONTINUE
  104.  23   CONTINUE
  105. *      NBLINI=ITOPO.NUM(/2)
  106.       NPTINI=IK
  107.       SEGINI IDCP
  108.       NPTBAS=XCOOR(/1)/IDIMP
  109.       DO 500 I=1,NPTBAS
  110.          if (icpr(i).ne.0) IDCP(ICPR(I))=I
  111.  500  CONTINUE
  112.       if (IMPR.GE.6) then
  113.          write(ioimp,*) 'Nb noeud globaux,locaux=',NPTBAS,IK
  114. *         write(ioimp,*) 'ICPR'
  115. *         write(ioimp,187) (ICPR(I),I=1,ICPR(/1))
  116.          write(ioimp,*) 'IDCP'
  117.          write(ioimp,187) (IDCP(I),I=1,IDCP(/1))
  118.       endif
  119.       IF (IMPR.GE.3) THEN
  120.          write(ioimp,*) 'quali7.eso : topologie en coord globales : '
  121.          call ecmai1(itopo,0)
  122.          segact itopo*mod
  123.       ENDIF
  124. *
  125. * Melemes en coordonnées locales
  126. *     Topologie
  127.       NLMAX=ITOPO.NUM(/2)
  128.       NNMAX=IDIMP
  129.       SEGINI,KTOPO
  130.       KTOPO.NLCOU=NLMAX
  131.       KTOPO.NNCOU=NNMAX
  132. *
  133.       DO 33 IEL=1,KTOPO.NLCOU
  134.          DO 330 INO=1,IDIMP
  135.             IP=ITOPO.NUM(INO,IEL)
  136.             KP=ICPR(IP)
  137.             IF (KP.NE.0) THEN
  138.                KTOPO.NUMX(INO,IEL)=KP
  139.             ELSE
  140.                WRITE(IOIMP,*) 'Erreur de programmation'
  141.                GOTO 9999
  142.             ENDIF
  143.  330     CONTINUE
  144.  33   CONTINUE
  145. * Eventuellement, IELEM=ITOP donc à désactiver ici
  146.       SEGDES ITOPO
  147.       IF (IMPR.GE.4) THEN
  148.          write(ioimp,*) 'quali7.eso : topologie en coord locales : '
  149.          call ecmelx(ktopo,0)
  150.       ENDIF
  151. * Pas de gestion de noeuds virtuels
  152.       NKPVIR=0
  153. * Passage des coordonnées en locale
  154.       NBPTS=NPTINI
  155.       SEGINI,KCOORD
  156.       DO 53 IPL=1,NBPTS
  157.          IREFL=IDIMP*(IPL-1)
  158.          IP=IDCP(IPL)
  159.          IREF=IDIMP*(IP-1)
  160.          DO 530 IC=1,IDIMP
  161.             KCOORD.XCOOR(IREFL+IC)=XCOOR(IREF+IC)
  162.  530     CONTINUE
  163.  53   CONTINUE
  164. * Passage de la métrique en local
  165. *
  166.       IF (ICMETR.NE.0) THEN
  167. *     Définition des noms de composantes
  168.          JGN=4
  169.          JGM=0
  170.          IF (IMET.EQ.3) JGM=1
  171. * On a enlevé le cas orthotrope
  172. *         IF (IMET.EQ.4) JGM=IDIM
  173.          IF (IMET.EQ.4) JGM=IDIM*(IDIM+1)/2
  174.          SEGINI KNMETR
  175.          DO I=1,JGM
  176.             KNMETR.MOTS(I)='G    '
  177.          ENDDO
  178. * On a enlevé le cas orthotrope
  179. *         IF (IMET.EQ.4) THEN
  180. *            DO I=1,IDIM
  181. *               WRITE(KNMETR.MOTS(I)(2:2),FMT='(I1)') I
  182. *            ENDDO
  183. *         ELSEIF (IMET.EQ.5) THEN
  184.          IF (IMET.EQ.4) THEN
  185.             idx=0
  186.             DO I=1,IDIM
  187.                DO J=1,I
  188.                   idx=idx+1
  189.                   WRITE(KNMETR.MOTS(idx)(2:2),FMT='(I1)') I
  190.                   WRITE(KNMETR.MOTS(idx)(3:3),FMT='(I1)') J
  191.                ENDDO
  192.             ENDDO
  193.          ENDIF
  194. *dbg         WRITE (IOIMP,2019) (KNMETR.MOTS(I),I=1,KNMETR.MOTS(/2))
  195. *dbg 2019    FORMAT (20(2X,A4) )
  196.          NNIN=KNMETR.MOTS(/2)
  197.          NNNOE=NBPTS
  198.          if (iveri.ge.1) SEGINI MISDEF
  199.          NNNOE=NBPTS
  200.          SEGINI KCMETR
  201.          MCHPOI=ICMETR
  202.          SEGACT MCHPOI
  203.          NSOUPO=IPCHP(/1)
  204.          DO ISOUPO=1,NSOUPO
  205.             MSOUPO=IPCHP(ISOUPO)
  206.             SEGACT MSOUPO
  207.             NC=NOCOMP(/2)
  208.             MELEME=IGEOC
  209.             MPOVAL=IPOVAL
  210.             SEGACT MELEME
  211.             SEGACT MPOVAL
  212.             N=VPOCHA(/1)
  213.             DO IC=1,NC
  214.                ININ=0
  215.                DO JNIN=1,NNIN
  216.                   IF (NOCOMP(IC).EQ.KNMETR.MOTS(JNIN)) THEN
  217.                      ININ=JNIN
  218.                      GOTO 11
  219.                   ENDIF
  220.                ENDDO
  221.  11            CONTINUE
  222.                IF (ININ.NE.0) THEN
  223.                   DO I=1,N
  224.                      INNOE=ICPR(NUM(1,I))
  225.                      IF (INNOE.NE.0) THEN
  226.                         if (iveri.ge.1) ISDEF(ININ,INNOE)=1
  227.                         KCMETR.XIN(ININ,INNOE)=VPOCHA(I,IC)
  228.                      ENDIF
  229.                   ENDDO
  230.                ENDIF
  231.             ENDDO
  232.             SEGDES MPOVAL
  233.             SEGDES MELEME
  234.             SEGDES MSOUPO
  235.          ENDDO
  236.          SEGDES MCHPOI
  237.          if (iveri.ge.1) then
  238. *     Vérification que la métrique a été définie sur tous les noeuds et
  239. *     toutes les composantes
  240.             DO J=1,ISDEF(/2)
  241.                DO I=1,ISDEF(/1)
  242.                   IF (ISDEF(I,J).NE.1) THEN
  243.                      MOT=KNMETR.MOTS(I)
  244.                      INOD=IDCP(J)
  245. *                        write(ioimp,*) 'iveri=',iveri
  246.                      write(ioimp,*)
  247.      $                    'Metrique non definie pour la composante '
  248.      $                    ,MOT,' au noeud ',INOD
  249.                      GOTO 9999
  250.                   ENDIF
  251.                ENDDO
  252.             ENDDO
  253.             SEGSUP MISDEF
  254.          endif
  255. *dbg         write(ioimp,*) 'Inimetr ok'
  256.       ELSE
  257.          KNMETR=0
  258.          KCMETR=0
  259.       ENDIF
  260. * La numérotation globale devient la locale dans ce bloc  !!!
  261.       MCOORD=KCOORD
  262.       IELDEB=1
  263.       IELFIN=KTOPO.NUMX(/2)
  264.       JG=IELFIN
  265.       SEGINI,MLREEL
  266.       CALL QUALI6(KTOPO,IELDEB,IELFIN,IMET,IMOMET,XDENS,KCMETR,NKPVIR
  267.      $     ,XVTOL,MLREEL,NQDC)
  268. * Point de branchement si erreur pendant le bloc en numérotation locale
  269.  555  CONTINUE
  270. *     On rétablit la numérotation globale originelle
  271. *     ! Attention, il faut aussi rétablir le NBPTS suite aux changements
  272. *     !  de Pierre dans SMCOORD
  273.       NBPTS=IBPTS
  274.       MCOORD=ICOORD
  275. *      write(ioimp,*) 'quali7 fin : nbpts, xcoor,idim=',
  276. *     $     nbpts,xcoor(/1)/(idim+1),idim
  277.       SEGDES,MCOORD
  278. *     On part en erreur après le rétablissement du MCOORD global
  279.       IF (IERR.NE.0) RETURN
  280.       JG=NQDC
  281.       SEGADJ,MLREEL
  282.       SEGDES,MLREEL
  283.       SEGSUP KCMETR
  284.       SEGSUP KNMETR
  285.       SEGSUP KCOORD
  286.       SEGSUP KTOPO
  287.       SEGSUP IDCP
  288.       SEGSUP ICPR
  289. *      write(ioimp,*) ' quali7  : apres segsup=',OOOVAL(2,1)
  290. *
  291. * Normal termination
  292. *
  293.       RETURN
  294. *
  295. * Format handling
  296. *
  297.  187  FORMAT (5X,10I8)
  298. *
  299. * Error handling
  300. *
  301.  9999 CONTINUE
  302.       MOTERR(1:8)='QUALI7  '
  303. * 349 2
  304. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  305.       CALL ERREUR(349)
  306.       RETURN
  307. *
  308. * End of subroutine QUALI7
  309. *
  310.       END
  311.  
  312.  

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