Télécharger la plaquette Cast3M


fr en

Télécharger extfac.eso

Retour à la liste

Numérotation des lignes : 

extfac

  1. C EXTFAC    SOURCE    GOUNAND   24/11/06    21:15:09     12073          
  2.       SUBROUTINE EXTFAC(CGEOM3,CSGEO3,MYQRFS,
  3.      $     CGEOME,FACTIV,
  4.      $     IMPR,IRET)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.       IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM         : EXTFAC
  9. C DESCRIPTION :  On extrait de CGEOM3 les éléments qui ont au moins une
  10. C                face appartenant à CSGEO3 et un objet MELEME détourné
  11. C                contenant les faces actives.
  12. C
  13. C
  14. C
  15. C LANGAGE     : ESOPE
  16. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  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, 17/12/2002, version initiale
  32. C HISTORIQUE : v1, 17/12/2002, création
  33. C HISTORIQUE :
  34. C HISTORIQUE :
  35. C***********************************************************************
  36. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  37. C en cas de modification de ce sous-programme afin de faciliter
  38. C la maintenance !
  39. C***********************************************************************
  40.  
  41. -INC PPARAM
  42. -INC CCOPTIO
  43. -INC SMCOORD
  44. -INC SMELEME
  45.       POINTEUR CGEOM3.MELEME,SCGEO3.MELEME
  46.       POINTEUR CSGEO3.MELEME,SCSGE3.MELEME
  47.       POINTEUR CGEOME.MELEME,SCGEOM.MELEME
  48.       POINTEUR FACVOL.MELEME,SFAVOL.MELEME
  49.       INTEGER NBNN,NBELEM,NBSOUS,NBREF
  50. * Segment à moi
  51.       SEGMENT VOLTIV
  52.       POINTEUR IVOLTI(NBSOUV).SVOLTI
  53.       ENDSEGMENT
  54.       SEGMENT SVOLTI
  55.       LOGICAL LVOLTI(NBELEV)
  56.       ENDSEGMENT
  57. -INC TNLIN
  58. *-INC SFACTIV
  59.       INTEGER NBSOUV,NBSOFV,NBELEV
  60. *-INC SMLLOGI
  61.       POINTEUR KRSURF.MLLOGI
  62.       INTEGER JG
  63. *-INC SIQUAF
  64.       POINTEUR MYQRFS.IQUAFS
  65.       POINTEUR IQUVOL.IQUAF
  66.       POINTEUR IQUFAC.IQUAF
  67. *
  68.       INTEGER IMPR,IRET
  69. *
  70.       INTEGER NBSOUF,NBELEF
  71.       INTEGER IBSOUF,IBELEF,IBSOUV,IBELEV
  72.       INTEGER        NBELFV,NBNNV,NBELVA
  73.       INTEGER IBSOFV,IBELFV,IBNNV,IBELVA
  74.       INTEGER NUCFAC,NGLFAC,NPLFAC,NPCFAC
  75.       INTEGER ITYVOL,ITYFAC
  76.       LOGICAL LFOUND
  77.  
  78.  
  79. *
  80. * Executable statements
  81. *
  82.       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans extfac.eso'
  83. *
  84. * On construit KRSURF : KRSURF(i) = VRAI si i est un numéro global
  85. * du centre d'un élément de CSGEO3 (point face)
  86. *
  87.       JG=nbpts
  88.       SEGINI,KRSURF
  89.       SEGACT CSGEO3
  90.       NBSOUF=CSGEO3.LISOUS(/1)
  91.       DO IBSOUF=1,NBSOUF
  92.          SCSGE3=CSGEO3.LISOUS(IBSOUF)
  93.          SEGACT SCSGE3
  94.          ITYFAC=SCSGE3.ITYPEL
  95.          CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  96.          IF (IRET.NE.0) GOTO 9999
  97.          SEGACT IQUFAC
  98.          NUCFAC=IQUFAC.NUCENT
  99.          SEGDES IQUFAC
  100.          NBELEF=SCSGE3.NUM(/2)
  101.          DO IBELEF=1,NBELEF
  102.             NGLFAC=SCSGE3.NUM(NUCFAC,IBELEF)
  103.             KRSURF.LOGI(NGLFAC)=.TRUE.
  104.          ENDDO
  105.          SEGDES SCSGE3
  106.       ENDDO
  107.       SEGDES CSGEO3
  108. *      segprt,krsurf
  109. *
  110. * On parcourt l'objet maillage CGEOM3 en notant les éléments ayant
  111. * au moins une face active LVOLTI(IBELEV)=.TRUE.
  112. *
  113.       SEGACT CGEOM3
  114.       NBSOUV=CGEOM3.LISOUS(/1)
  115.       SEGINI,VOLTIV
  116.       DO IBSOUV=1,NBSOUV
  117.          SCGEO3=CGEOM3.LISOUS(IBSOUV)
  118.          SEGACT SCGEO3
  119.          NBELEV=SCGEO3.NUM(/2)
  120.          SEGINI,SVOLTI
  121.          ITYVOL=SCGEO3.ITYPEL
  122.          CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  123.          IF (IRET.NE.0) GOTO 9999
  124.          SEGACT IQUVOL
  125.          FACVOL=IQUVOL.LFACE
  126.          SEGDES IQUVOL
  127.          SEGACT FACVOL
  128.          NBSOFV=FACVOL.LISOUS(/1)
  129.          DO IBSOFV=1,NBSOFV
  130.             SFAVOL=FACVOL.LISOUS(IBSOFV)
  131. *            segprt,sfavol
  132.             SEGACT SFAVOL
  133.             ITYFAC=SFAVOL.ITYPEL
  134.             CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  135.             IF (IRET.NE.0) GOTO 9999
  136.             SEGACT IQUFAC
  137.             NUCFAC=IQUFAC.NUCENT
  138.             SEGDES IQUFAC
  139.             NBELFV=SFAVOL.NUM(/2)
  140.             DO IBELEV=1,NBELEV
  141.                LFOUND=.FALSE.
  142.                DO IBELFV=1,NBELFV
  143.                   NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
  144.                   NPCFAC=SCGEO3.NUM(NPLFAC,IBELEV)
  145. *                  Write(ioimp,*) 'nplfac=',nplfac,' npcfac=',npcfac
  146.                   LFOUND=LFOUND.OR.KRSURF.LOGI(NPCFAC)
  147.                ENDDO
  148.                SVOLTI.LVOLTI(IBELEV)=LFOUND.OR.SVOLTI.LVOLTI(IBELEV)
  149.             ENDDO
  150.             SEGDES,SFAVOL
  151.          ENDDO
  152.          SEGDES,SVOLTI
  153. *         SEGPRT,SVOLTI
  154.          VOLTIV.IVOLTI(IBSOUV)=SVOLTI
  155.          SEGDES FACVOL
  156.          SEGDES SCGEO3
  157.       ENDDO
  158.       SEGDES VOLTIV
  159.       SEGDES CGEOM3
  160. *
  161. * On construit l'objet maillage CGEOME contenant uniquement
  162. * les éléments ayant au moins une face active
  163. *
  164.       SEGACT CGEOM3
  165.       NBSOUV=CGEOM3.LISOUS(/1)
  166.       NBNN=0
  167.       NBELEM=0
  168.       NBSOUS=NBSOUV
  169.       NBREF=NBSOUV
  170.       SEGINI CGEOME
  171.       SEGACT VOLTIV
  172.       IBSOV2=0
  173.       DO IBSOUV=1,NBSOUV
  174.          SCGEO3=CGEOM3.LISOUS(IBSOUV)
  175.          SEGACT SCGEO3
  176.          NBNNV=SCGEO3.NUM(/1)
  177.          NBELEV=SCGEO3.NUM(/2)
  178.          SVOLTI=VOLTIV.IVOLTI(IBSOUV)
  179.          SEGACT SVOLTI
  180. *   Trouver le nombre d'éléments actifs dans ce maillage élémentaire
  181.          NBELVA=0
  182.          DO IBELEV=1,NBELEV
  183.             IF (SVOLTI.LVOLTI(IBELEV)) THEN
  184.                NBELVA=NBELVA+1
  185.             ENDIF
  186.          ENDDO
  187.          IF (NBELVA.GT.0) THEN
  188.             NBNN=NBNNV
  189.             NBELEM=NBELVA
  190.             NBSOUS=0
  191.             NBREF=0
  192.             SEGINI,SCGEOM
  193.             SCGEOM.ITYPEL=SCGEO3.ITYPEL
  194.             IPT1=CGEOM3.LISREF(IBSOUV)
  195.             IF (IPT1.NE.0) THEN
  196.                SEGINI MELEME
  197.             ENDIF
  198.  
  199.             IBELVA=0
  200.             DO IBELEV=1,NBELEV
  201.                IF (SVOLTI.LVOLTI(IBELEV)) THEN
  202.                   IBELVA=IBELVA+1
  203.                   DO IBNNV=1,NBNNV
  204.                      SCGEOM.NUM(IBNNV,IBELVA)=SCGEO3.NUM(IBNNV,IBELEV)
  205.                      IF (IPT1.NE.0) THEN
  206.                         NUM(IBNNV,IBELVA)=IPT1.NUM(IBNNV,IBELEV)
  207.                      ENDIF
  208.                   ENDDO
  209.                ENDIF
  210.             ENDDO
  211.             SEGDES,SCGEOM
  212.             IBSOV2=IBSOV2+1
  213.             CGEOME.LISOUS(IBSOV2)=SCGEOM
  214.             IF (IPT1.NE.0) THEN
  215.                SEGDES MELEME
  216.                CGEOME.LISREF(IBSOV2)=MELEME
  217.             ENDIF
  218.          ENDIF
  219. *DEBUG         SEGPRT,SVOLTI
  220.          SEGSUP SVOLTI
  221.          SEGDES SCGEO3
  222.       ENDDO
  223. *DEBUG      SEGPRT,VOLTIV
  224.       SEGSUP VOLTIV
  225.       NBNN=0
  226.       NBELEM=0
  227.       NBSOUS=IBSOV2
  228.       NBREF=IBSOV2
  229.       SEGADJ,CGEOME
  230.       SEGDES CGEOME
  231.       SEGDES CGEOM3
  232. *DEBUG      CALL ECROBJ('MAILLAGE',CGEOME)
  233. *DEBUG      CALL PRLIST
  234. *DEBUG      CALL ECROBJ('MAILLAGE',CGEOM3)
  235. *DEBUG      CALL PRLIST
  236. *
  237. * On parcourt l'objet maillage CGEOME en notant les faces actives des
  238. * éléments LFACTI(IBFAVO,IBELEV)=.TRUE.
  239. *
  240.       SEGACT CGEOME
  241.       NBSOUV=CGEOME.LISOUS(/1)
  242.       SEGINI,FACTIV
  243.       DO IBSOUV=1,NBSOUV
  244.          SCGEOM=CGEOME.LISOUS(IBSOUV)
  245.          SEGACT SCGEOM
  246.          ITYVOL=SCGEOM.ITYPEL
  247.          CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  248.          IF (IRET.NE.0) GOTO 9999
  249.          SEGACT IQUVOL
  250.          FACVOL=IQUVOL.LFACE
  251.          SEGDES IQUVOL
  252.          SEGACT FACVOL
  253.          NBSOFV=FACVOL.LISOUS(/1)
  254.          SEGINI,SFACTI
  255.          DO IBSOFV=1,NBSOFV
  256.             SFAVOL=FACVOL.LISOUS(IBSOFV)
  257.             SEGACT SFAVOL
  258.             ITYFAC=SFAVOL.ITYPEL
  259.             CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  260.             IF (IRET.NE.0) GOTO 9999
  261.             SEGACT IQUFAC
  262.             NUCFAC=IQUFAC.NUCENT
  263.             SEGDES IQUFAC
  264.             NBELFV=SFAVOL.NUM(/2)
  265.             NBELEV=SCGEOM.NUM(/2)
  266.             SEGINI SSFACT
  267.             DO IBELEV=1,NBELEV
  268.                DO IBELFV=1,NBELFV
  269.                   NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
  270.                   NPCFAC=SCGEOM.NUM(NPLFAC,IBELEV)
  271.                   SSFACT.LFACTI(IBELFV,IBELEV)=KRSURF.LOGI(NPCFAC)
  272.                ENDDO
  273.             ENDDO
  274.             SEGDES SSFACT
  275. *            SEGPRT,SSFACT
  276.             SFACTI.ISFACT(IBSOFV)=SSFACT
  277.             SEGDES SFAVOL
  278.          ENDDO
  279.          SEGDES SFACTI
  280. *         SEGPRT,SFACTI
  281.          FACTIV.IFACTI(IBSOUV)=SFACTI
  282.          SEGDES FACVOL
  283.          SEGDES SCGEOM
  284.       ENDDO
  285.       SEGDES FACTIV
  286. *      SEGPRT,FACTIV
  287.       SEGDES CGEOME
  288.       SEGSUP,KRSURF
  289. *
  290. * Normal termination
  291. *
  292.       IRET=0
  293.       RETURN
  294. *
  295. * Format handling
  296. *
  297. *
  298. * Error handling
  299. *
  300.  9999 CONTINUE
  301.       IRET=1
  302.       WRITE(IOIMP,*) 'An error was detected in subroutine extfac'
  303.       RETURN
  304. *
  305. * End of subroutine EXTFAC
  306. *
  307.       END
  308.  
  309.  

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