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   21/04/01    21:15:08     10933          
  2.       SUBROUTINE QUALI7(ITOPO,IPVIRT,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.  
  152. *     Noeud virtuel en coordonnées locales
  153.       IF (IPVIRT.NE.0) THEN
  154.          KPVIRT=ICPR(IPVIRT)
  155. * Ici, c'est normal de ne pas être inclus         
  156. *         IF (KPVIRT.EQ.0) THEN
  157. *            write(ioimp,*)
  158. *     $           'Noeud virtuel non inclus dans la topologie ?'
  159. *            goto 9999
  160. *         ENDIF
  161.       ELSE
  162.          KPVIRT=0
  163.       ENDIF
  164.       IF (IMPR.GE.4) THEN
  165.          write(ioimp,*) 'quali7.eso : noeud virtuel en coord locales : '
  166.      $        ,KPVIRT
  167.       ENDIF         
  168. * Passage des coordonnées en locale
  169.       NBPTS=NPTINI
  170.       SEGINI,KCOORD
  171.       DO 53 IPL=1,NBPTS
  172.          IREFL=IDIMP*(IPL-1)
  173.          IP=IDCP(IPL)
  174.          IREF=IDIMP*(IP-1)
  175.          DO 530 IC=1,IDIMP
  176.             KCOORD.XCOOR(IREFL+IC)=XCOOR(IREF+IC)
  177.  530     CONTINUE
  178.  53   CONTINUE
  179. * Passage de la métrique en local
  180. *
  181.       IF (ICMETR.NE.0) THEN
  182. *     Définition des noms de composantes
  183.          JGN=4
  184.          JGM=0
  185.          IF (IMET.EQ.3) JGM=1
  186. * On a enlevé le cas orthotrope         
  187. *         IF (IMET.EQ.4) JGM=IDIM
  188.          IF (IMET.EQ.4) JGM=IDIM*(IDIM+1)/2
  189.          SEGINI KNMETR
  190.          DO I=1,JGM
  191.             KNMETR.MOTS(I)='G    '
  192.          ENDDO
  193. * On a enlevé le cas orthotrope         
  194. *         IF (IMET.EQ.4) THEN
  195. *            DO I=1,IDIM
  196. *               WRITE(KNMETR.MOTS(I)(2:2),FMT='(I1)') I
  197. *            ENDDO
  198. *         ELSEIF (IMET.EQ.5) THEN            
  199.          IF (IMET.EQ.4) THEN
  200.             idx=0
  201.             DO I=1,IDIM
  202.                DO J=1,I
  203.                   idx=idx+1
  204.                   WRITE(KNMETR.MOTS(idx)(2:2),FMT='(I1)') I
  205.                   WRITE(KNMETR.MOTS(idx)(3:3),FMT='(I1)') J
  206.                ENDDO
  207.             ENDDO
  208.          ENDIF
  209. *dbg         WRITE (IOIMP,2019) (KNMETR.MOTS(I),I=1,KNMETR.MOTS(/2))
  210. *dbg 2019    FORMAT (20(2X,A4) )
  211.          NNIN=KNMETR.MOTS(/2)
  212.          NNNOE=NBPTS
  213.          if (iveri.ge.1) SEGINI MISDEF
  214.          NNNOE=NBPTS
  215.          SEGINI KCMETR
  216.          MCHPOI=ICMETR
  217.          SEGACT MCHPOI
  218.          NSOUPO=IPCHP(/1)
  219.          DO ISOUPO=1,NSOUPO
  220.             MSOUPO=IPCHP(ISOUPO)
  221.             SEGACT MSOUPO
  222.             NC=NOCOMP(/2)
  223.             MELEME=IGEOC
  224.             MPOVAL=IPOVAL
  225.             SEGACT MELEME
  226.             SEGACT MPOVAL
  227.             N=VPOCHA(/1)
  228.             DO IC=1,NC
  229.                ININ=0
  230.                DO JNIN=1,NNIN
  231.                   IF (NOCOMP(IC).EQ.KNMETR.MOTS(JNIN)) THEN
  232.                      ININ=JNIN
  233.                      GOTO 11
  234.                   ENDIF
  235.                ENDDO
  236.  11            CONTINUE
  237.                IF (ININ.NE.0) THEN
  238.                   DO I=1,N
  239.                      INNOE=ICPR(NUM(1,I))
  240.                      IF (INNOE.NE.0) THEN
  241.                         if (iveri.ge.1) ISDEF(ININ,INNOE)=1
  242.                         KCMETR.XIN(ININ,INNOE)=VPOCHA(I,IC)
  243.                      ENDIF
  244.                   ENDDO
  245.                ENDIF
  246.             ENDDO
  247.             SEGDES MPOVAL
  248.             SEGDES MELEME
  249.             SEGDES MSOUPO
  250.          ENDDO
  251.          SEGDES MCHPOI
  252.          if (iveri.ge.1) then
  253. *     Vérification que la métrique a été définie sur tous les noeuds et
  254. *     toutes les composantes
  255.             DO J=1,ISDEF(/2)
  256.                IF (J.NE.IPVIRT) THEN
  257.                   DO I=1,ISDEF(/1)
  258.                      IF (ISDEF(I,J).NE.1) THEN
  259.                         MOT=KNMETR.MOTS(I)
  260.                         INOD=IDCP(J)
  261. *                        write(ioimp,*) 'iveri=',iveri
  262.                         write(ioimp,*)
  263.      $                       'Metrique non definie pour la composante '
  264.      $                       ,MOT,' au noeud ',INOD
  265.                         GOTO 9999
  266.                      ENDIF
  267.                   ENDDO
  268.                ENDIF
  269.             ENDDO
  270.             SEGSUP MISDEF
  271.          endif
  272. *dbg         write(ioimp,*) 'Inimetr ok'
  273.       ELSE
  274.          KNMETR=0
  275.          KCMETR=0
  276.       ENDIF
  277. * La numérotation globale devient la locale dans ce bloc  !!!
  278.       MCOORD=KCOORD
  279.       IELDEB=1
  280.       IELFIN=KTOPO.NUMX(/2)
  281.       JG=IELFIN
  282.       SEGINI,MLREEL
  283.       CALL QUALI6(KTOPO,IELDEB,IELFIN,IMET,IMOMET,XDENS,KCMETR,KPVIRT
  284.      $     ,XVTOL,MLREEL,NQDC)
  285. * Point de branchement si erreur pendant le bloc en numérotation locale
  286.  555  CONTINUE
  287. *     On rétablit la numérotation globale originelle
  288. *     ! Attention, il faut aussi rétablir le NBPTS suite aux changements
  289. *     !  de Pierre dans SMCOORD
  290.       NBPTS=IBPTS
  291.       MCOORD=ICOORD
  292. *      write(ioimp,*) 'quali7 fin : nbpts, xcoor,idim=',
  293. *     $     nbpts,xcoor(/1)/(idim+1),idim
  294.       SEGDES,MCOORD
  295. *     On part en erreur après le rétablissement du MCOORD global
  296.       IF (IERR.NE.0) RETURN
  297.       JG=NQDC
  298.       SEGADJ,MLREEL
  299.       SEGDES,MLREEL
  300.       SEGSUP KCMETR
  301.       SEGSUP KNMETR
  302.       SEGSUP KCOORD
  303.       SEGSUP KTOPO
  304.       SEGSUP IDCP
  305.       SEGSUP ICPR
  306. *      write(ioimp,*) ' quali7  : apres segsup=',OOOVAL(2,1)
  307. *
  308. * Normal termination
  309. *
  310.       RETURN
  311. *
  312. * Format handling
  313. *
  314.  184  FORMAT (2X,'noeud ip=',i4,' relie aux elements')
  315.  185  FORMAT (/2X,10(A16,'=',I8,2X)/)
  316.  186  FORMAT (2X,10(A6,'=',I6,2X))
  317.  187  FORMAT (5X,10I8)
  318.  188  FORMAT (5X,10(1X,1PG12.5))
  319. *     
  320. * Error handling     
  321. *     
  322.  9999 CONTINUE
  323.       MOTERR(1:8)='QUALI7  '
  324. * 349 2
  325. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  326.       CALL ERREUR(349)
  327.       RETURN
  328. *
  329. * End of subroutine QUALI7
  330. *
  331.       END
  332.  
  333.  
  334.  

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