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   21/06/02    21:15:51     11022          
  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=0
  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.             IBELVA=0
  195.             DO IBELEV=1,NBELEV
  196.                IF (SVOLTI.LVOLTI(IBELEV)) THEN
  197.                   IBELVA=IBELVA+1
  198.                   DO IBNNV=1,NBNNV
  199.                      SCGEOM.NUM(IBNNV,IBELVA)=SCGEO3.NUM(IBNNV,IBELEV)
  200.                   ENDDO
  201.                ENDIF
  202.             ENDDO
  203.             SEGDES,SCGEOM
  204.             IBSOV2=IBSOV2+1
  205.             CGEOME.LISOUS(IBSOV2)=SCGEOM
  206.          ENDIF
  207. *DEBUG         SEGPRT,SVOLTI
  208.          SEGSUP SVOLTI
  209.          SEGDES SCGEO3
  210.       ENDDO
  211. *DEBUG      SEGPRT,VOLTIV
  212.       SEGSUP VOLTIV
  213.       NBNN=0
  214.       NBELEM=0
  215.       NBSOUS=IBSOV2
  216.       NBREF=0
  217.       SEGADJ,CGEOME
  218.       SEGDES CGEOME
  219.       SEGDES CGEOM3
  220. *DEBUG      CALL ECROBJ('MAILLAGE',CGEOME)
  221. *DEBUG      CALL PRLIST
  222. *DEBUG      CALL ECROBJ('MAILLAGE',CGEOM3)
  223. *DEBUG      CALL PRLIST
  224. *
  225. * On parcourt l'objet maillage CGEOME en notant les faces actives des
  226. * éléments LFACTI(IBFAVO,IBELEV)=.TRUE.
  227. *
  228.       SEGACT CGEOME
  229.       NBSOUV=CGEOME.LISOUS(/1)
  230.       SEGINI,FACTIV
  231.       DO IBSOUV=1,NBSOUV
  232.          SCGEOM=CGEOME.LISOUS(IBSOUV)
  233.          SEGACT SCGEOM
  234.          ITYVOL=SCGEOM.ITYPEL
  235.          CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  236.          IF (IRET.NE.0) GOTO 9999
  237.          SEGACT IQUVOL
  238.          FACVOL=IQUVOL.LFACE
  239.          SEGDES IQUVOL
  240.          SEGACT FACVOL
  241.          NBSOFV=FACVOL.LISOUS(/1)
  242.          SEGINI,SFACTI
  243.          DO IBSOFV=1,NBSOFV
  244.             SFAVOL=FACVOL.LISOUS(IBSOFV)
  245.             SEGACT SFAVOL
  246.             ITYFAC=SFAVOL.ITYPEL
  247.             CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  248.             IF (IRET.NE.0) GOTO 9999
  249.             SEGACT IQUFAC
  250.             NUCFAC=IQUFAC.NUCENT
  251.             SEGDES IQUFAC
  252.             NBELFV=SFAVOL.NUM(/2)
  253.             NBELEV=SCGEOM.NUM(/2)
  254.             SEGINI SSFACT
  255.             DO IBELEV=1,NBELEV
  256.                DO IBELFV=1,NBELFV
  257.                   NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
  258.                   NPCFAC=SCGEOM.NUM(NPLFAC,IBELEV)
  259.                   SSFACT.LFACTI(IBELFV,IBELEV)=KRSURF.LOGI(NPCFAC)
  260.                ENDDO
  261.             ENDDO
  262.             SEGDES SSFACT
  263. *            SEGPRT,SSFACT
  264.             SFACTI.ISFACT(IBSOFV)=SSFACT
  265.             SEGDES SFAVOL
  266.          ENDDO
  267.          SEGDES SFACTI
  268. *         SEGPRT,SFACTI
  269.          FACTIV.IFACTI(IBSOUV)=SFACTI
  270.          SEGDES FACVOL
  271.          SEGDES SCGEOM
  272.       ENDDO
  273.       SEGDES FACTIV
  274. *      SEGPRT,FACTIV
  275.       SEGDES CGEOME
  276.       SEGSUP,KRSURF
  277. *
  278. * Normal termination
  279. *
  280.       IRET=0
  281.       RETURN
  282. *
  283. * Format handling
  284. *
  285. *
  286. * Error handling
  287. *
  288.  9999 CONTINUE
  289.       IRET=1
  290.       WRITE(IOIMP,*) 'An error was detected in subroutine extfac'
  291.       RETURN
  292. *
  293. * End of subroutine EXTFAC
  294. *
  295.       END
  296.  
  297.  
  298.  
  299.  
  300.  

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