Télécharger la plaquette Cast3M


fr en

Télécharger meland.eso

Retour à la liste

Numérotation des lignes : 

meland

  1. C MELAND    SOURCE    FANDEUR   22/05/02    21:15:25     11359          
  2.       SUBROUTINE MELAND(GPMELS,
  3.      $     MAICOM,
  4.      $     IMPR,IRET)
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM         : MELAND
  9. C DESCRIPTION : Renvoie le maillage de points (POI1) MAICOM des
  10. C               points appartenant à tous les maillages de gpmels.
  11. C
  12. C LANGAGE     : ESOPE
  13. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  14. C               mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C APPELES          : -
  17. C APPELE PAR       : MELCOM
  18. C***********************************************************************
  19. C ENTREES            : GPMELS
  20. C SORTIES            : MAICOM
  21. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  22. C***********************************************************************
  23. C VERSION    : v1, 12/05/99, version initiale
  24. C HISTORIQUE : v1, 12/05/99, création
  25. C HISTORIQUE :
  26. C HISTORIQUE :
  27. C***********************************************************************
  28. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  29. C en cas de modification de ce sous-programme afin de faciliter
  30. C la maintenance !
  31. C***********************************************************************
  32.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC SMCOORD
  36. -INC SMELEME
  37.       POINTEUR MELCOU.MELEME
  38.       POINTEUR SOUMEL.MELEME
  39.       INTEGER NBELEM,NBNN,NBREF,NBSOUS
  40.       POINTEUR MAICOM.MELEME
  41. -INC SMLENTI
  42.       INTEGER JG
  43.       POINTEUR IWORK.MLENTI
  44. *
  45. * Includes persos
  46. *
  47.       SEGMENT MELS
  48.       POINTEUR LISMEL(NBMEL).MELEME
  49.       ENDSEGMENT
  50.       POINTEUR GPMELS.MELS
  51. *
  52.       INTEGER IMPR,IRET
  53. *
  54.       LOGICAL BSAME
  55.       INTEGER BEGI,LAST,ILAST,IPREC,LDG,ILDG,NUMNO
  56.       INTEGER IELEM,IPOEL,ISOUS,IMEL
  57.       INTEGER NELEM,NPOEL,NSOUS,NMEL
  58. *
  59. * Executable statements
  60. *
  61.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans meland.eso'
  62.       SEGACT GPMELS
  63.       NMEL=GPMELS.LISMEL(/1)
  64.       IF (NMEL.LE.0) THEN
  65.          WRITE(IOIMP,*) 'Nombre de MELEMEs négatif ou nul'
  66.          GOTO 9999
  67.       ENDIF
  68. * On cherche le cas évident :
  69. * - Maillage tous identiques de POI1
  70.       MELCOU=GPMELS.LISMEL(1)
  71.       SEGACT MELCOU
  72.       BSAME=.FALSE.
  73.       IF (MELCOU.ITYPEL.EQ.1) THEN
  74.          BSAME=.TRUE.
  75.          DO 1 IMEL=2,NMEL
  76.             IF (GPMELS.LISMEL(IMEL).NE.MELCOU) THEN
  77.                BSAME=.FALSE.
  78.             ENDIF
  79.  1       CONTINUE
  80.       ENDIF
  81.       SEGDES MELCOU
  82.       IF (BSAME) THEN
  83.          SEGINI,MAICOM=MELCOU
  84.          SEGDES MAICOM
  85.       ELSE
  86. * - On construit la liste chaînée avec le premier maillage
  87.          JG=nbpts
  88.          SEGINI IWORK
  89. *   degré, fin de la liste chaînée
  90.          LDG=0
  91.          BEGI=nbpts+1
  92.          LAST=BEGI
  93.          MELCOU=GPMELS.LISMEL(1)
  94.          SEGACT MELCOU
  95.          NSOUS=MELCOU.LISOUS(/1)
  96.          DO 3 ISOUS=1,MAX(1,NSOUS)
  97.             IF (NSOUS.EQ.0) THEN
  98.                SOUMEL=MELCOU
  99.             ELSE
  100.                SOUMEL=MELCOU.LISOUS(ISOUS)
  101.                SEGACT SOUMEL
  102.             ENDIF
  103.             NPOEL=SOUMEL.NUM(/1)
  104.             NELEM=SOUMEL.NUM(/2)
  105.             DO 32 IELEM=1,NELEM
  106.                DO 322 IPOEL=1,NPOEL
  107.                   NUMNO=SOUMEL.NUM(IPOEL,IELEM)
  108.                   IF (IWORK.LECT(NUMNO).EQ.0) THEN
  109.                      LDG=LDG+1
  110.                      IWORK.LECT(NUMNO)=LAST
  111.                      LAST=NUMNO
  112.                   ENDIF
  113.  322           CONTINUE
  114.  32         CONTINUE
  115.             IF (NSOUS.NE.0) THEN
  116.                SEGDES SOUMEL
  117.             ENDIF
  118.  3       CONTINUE
  119.          SEGDES MELCOU
  120. * - On réduit la liste chaînée des points des autres maillages
  121. *   qui ne sont pas déjà dedans
  122. *COMM         write(ioimp,*) 'nmel=',nmel
  123.          DO 5 IMEL=2,NMEL
  124. *COMM            write(ioimp,*) 'last,ldg,imel',LAST,LDG,IMEL
  125. *COMM            SEGPRT,IWORK
  126. * On attribue le signe - à tous les points de la liste chaînée
  127.             NUMNO=LAST
  128.             DO 52 ILDG=1,LDG
  129.                IPREC=IWORK.LECT(NUMNO)
  130.                IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO)
  131.                NUMNO=IPREC
  132.  52         CONTINUE
  133. *COMM            write(ioimp,*) 'négativation'
  134. *COMM            SEGPRT,IWORK
  135.             MELCOU=GPMELS.LISMEL(IMEL)
  136. * On attribue le signe + aux points de la liste chaînée
  137. * qui sont dans le IMEL ième maillage
  138.             SEGACT MELCOU
  139.             NSOUS=MELCOU.LISOUS(/1)
  140.             DO 54 ISOUS=1,MAX(1,NSOUS)
  141.                IF (NSOUS.EQ.0) THEN
  142.                   SOUMEL=MELCOU
  143.                ELSE
  144.                   SOUMEL=MELCOU.LISOUS(ISOUS)
  145.                   SEGACT SOUMEL
  146.                ENDIF
  147.                NPOEL=SOUMEL.NUM(/1)
  148.                NELEM=SOUMEL.NUM(/2)
  149.                DO 542 IELEM=1,NELEM
  150.                   DO 5422 IPOEL=1,NPOEL
  151.                      NUMNO=SOUMEL.NUM(IPOEL,IELEM)
  152.                      IF (IWORK.LECT(NUMNO).LT.0) THEN
  153.                         IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO)
  154.                      ENDIF
  155.  5422             CONTINUE
  156.  542           CONTINUE
  157.                IF (NSOUS.NE.0) THEN
  158.                   SEGDES SOUMEL
  159.                ENDIF
  160.  54         CONTINUE
  161.             SEGDES MELCOU
  162. *COMM            write(ioimp,*) 'positivation'
  163. *COMM            SEGPRT,IWORK
  164. * On nettoie la liste chaînée des points qui sont restés
  165. * avec le signe négatif
  166. *
  167. * D'abord, on cherche la fin de ce qui sera la nouvelle liste
  168. *   If (LAST.EQ.BEGI), la liste résultat est vide
  169.             IF (LAST.NE.BEGI) THEN
  170.                NUMNO=LAST
  171.  56            CONTINUE
  172.                IPREC=IWORK.LECT(NUMNO)
  173.                IF (IPREC.LT.0) THEN
  174.                   LDG=LDG-1
  175.                   IWORK.LECT(NUMNO)=0
  176.                   NUMNO=-IPREC
  177.                   IF (NUMNO.NE.BEGI) THEN
  178.                      GOTO 56
  179.                   ENDIF
  180.                ENDIF
  181.                LAST=NUMNO
  182.             ENDIF
  183. *COMM            write(ioimp,*) 'Fin de la liste=',LAST
  184. * Une fois obtenue la fin de la liste résultat, on continue
  185. *   If (LAST.EQ.BEGI), la liste résultat est vide
  186.             IF (LAST.NE.BEGI) THEN
  187.                ILAST=LAST
  188.                NUMNO=LAST
  189. *   IPREC est forcément positif sinon, LAST n'aurait pas la bonne valeur
  190.                IPREC=IWORK.LECT(NUMNO)
  191.                NUMNO=IPREC
  192. *COMM               write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC
  193.                IF (NUMNO.NE.BEGI) THEN
  194.  58               CONTINUE
  195.                   IPREC=IWORK.LECT(NUMNO)
  196. *COMM                  write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC
  197.                   IF (IPREC.LT.0) THEN
  198.                      LDG=LDG-1
  199.                      IWORK.LECT(NUMNO)=0
  200.                      NUMNO=-IPREC
  201.                   ELSE
  202.                      IWORK.LECT(ILAST)=NUMNO
  203.                      ILAST=NUMNO
  204.                      NUMNO=IPREC
  205.                   ENDIF
  206.                   IF (NUMNO.NE.BEGI) THEN
  207.                      GOTO 58
  208.                   ENDIF
  209.                ENDIF
  210.                IWORK.LECT(ILAST)=BEGI
  211. *COMM               write(ioimp,*) 'nettoyage'
  212. *COMM               SEGPRT,IWORK
  213.             ENDIF
  214.  5       CONTINUE
  215. * Créer le maillage de points correspondant à la liste chaînée
  216.          NBNN=1
  217.          NBELEM=LDG
  218.          NBSOUS=0
  219.          NBREF=0
  220.          SEGINI MAICOM
  221.          MAICOM.ITYPEL=1
  222.          NUMNO=LAST
  223.          DO 7 ILDG=1,LDG
  224.             IPREC=IWORK.LECT(NUMNO)
  225.             MAICOM.NUM(1,ILDG)=NUMNO
  226.             NUMNO=IPREC
  227.  7       CONTINUE
  228.          SEGDES MAICOM
  229.          SEGSUP IWORK
  230.       ENDIF
  231.       SEGDES GPMELS
  232.       IF (IMPR.GT.2) THEN
  233.          WRITE(IOIMP,*) 'On a créé MAICOM=',MAICOM
  234.          IF (IMPR.GT.3) THEN
  235.             SEGPRT,MAICOM
  236.          ENDIF
  237.       ENDIF
  238. *
  239. * Normal termination
  240. *
  241.       IRET=0
  242.       RETURN
  243. *
  244. * Format handling
  245. *
  246. *
  247. * Error handling
  248. *
  249.  9999 CONTINUE
  250.       IRET=1
  251.       WRITE(IOIMP,*) 'An error was detected in subroutine meland'
  252.       RETURN
  253. *
  254. * End of subroutine MELAND
  255. *
  256.       END
  257.  
  258.  
  259.  

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