Télécharger la plaquette Cast3M


fr en

Télécharger faccvx.eso

Retour à la liste

Numérotation des lignes : 

faccvx

  1. C FACCVX    SOURCE    OF166741  24/10/03    21:15:11     12022          
  2.         SUBROUTINE FACCVX(MYMOD,INFOEL,NGAUSS,ICHFAC)
  3. C_______________________________________________________________________
  4. C    Calcul des facteurs de forme en 2D-plan et 3D pour une geometrie
  5. C    convexe
  6. C    Pas de coques avec l'option convexe
  7. C    Traitement des quadratiques en se ramenant a des elements
  8. C    lineaires 'enveloppe'
  9. C_______________________________________________________________________
  10. C    Arguments   :
  11. C    in : MYMOD  : objet MMODEL contenant la geometrie
  12. C    in : NGAUSS : nombre de points de Gauss en 3D (INTEGER )
  13. C    out: ICHFAC : objet MCHAML contenant les facteurs de forme
  14. C_______________________________________________________________________
  15. C
  16.       IMPLICIT INTEGER(I-N)
  17.       IMPLICIT REAL*8 (A-H,O-Z)
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC SMMODEL
  21. -INC SMELEME
  22. -INC SMCOORD
  23.         POINTEUR MYMOD.MMODEL
  24.         POINTEUR  ISSMA.MELEME , ISSMB.MELEME
  25. C_______________________________________________________________________
  26. C     FACTEURS DE FORME
  27. C           NNBEL1 = NOMBRE DE LIGNES + 1
  28. C           NBEL2  = NOMBRE DE COLONNES
  29. C     LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
  30. C
  31.       SEGMENT IFACFO
  32.         INTEGER   LFACT(NNBEL1)
  33.       ENDSEGMENT
  34.       SEGMENT LFAC
  35.         REAL*8    FACT(NBEL2)
  36.       ENDSEGMENT
  37.       POINTEUR PSUR.LFAC, PLIG.LFAC
  38.       POINTEUR PCOL.LFAC
  39. C_______________________________________________________________________
  40.       SEGMENT,INFOEL
  41.         LOGICAL KCOQ(N1), KQUAD(N1)
  42.       ENDSEGMENT
  43. C_______________________________________________________________________
  44. C   structures nécessaires aux arguments de sous-programmes
  45.       SEGMENT PMATG
  46.         REAL*8   G(11,10)
  47.       ENDSEGMENT
  48.       SEGMENT PTRA23
  49.         INTEGER  NYA(5),NYB(5)
  50.         REAL*8   AM(IDIM,5),BM(IDIM,5),UA(IDIM+1),UB(IDIM+1)
  51.       ENDSEGMENT
  52.       LOGICAL  MALEUR
  53.       LOGICAL ICOQ
  54. C_______________________________________________________________________
  55. C
  56.       KIMP=IIMPI
  57.       MALEUR = .FALSE.
  58.       EDIS = 0.00001
  59. C...    elements quadratiques
  60.       NSPA1=1
  61.       NSPA2=1
  62.  
  63.       IF (INFOEL.EQ.0) THEN
  64.         ICOQ= .FALSE.
  65.       ELSE
  66.         ICOQ= .TRUE.
  67.         SEGACT INFOEL
  68.       ENDIF
  69. C
  70. C     Calcul du nombre de faces NFACE et activation de maillages
  71. C
  72.       N1 = MYMOD.KMODEL(/1)
  73.       NFACE = 0
  74.       DO 10 ITYP=1,N1
  75.         IMODEL = MYMOD.KMODEL(ITYP)
  76.         IPT1 = IMAMOD
  77.         NFACE = NFACE + IPT1.NUM(/2)
  78.   10  CONTINUE
  79. C
  80. C>>>  INITIALISATION OBJET FACFOR
  81. C     ---------------------------
  82. C
  83.       NNBEL1=NFACE+1
  84.       NBEL2=NFACE
  85.       SEGINI IFACFO
  86.       DO 900 LS=1,NNBEL1
  87.         SEGINI PLIG
  88.         LFACT(LS)=PLIG
  89.         SEGACT PLIG*MOD
  90.  900  CONTINUE
  91.       PSUR = LFACT(NNBEL1)
  92.       SEGACT PSUR*MOD
  93.  
  94. C     -------------------------------------------------------------
  95. C
  96.       IF (IDIM.EQ.3) THEN
  97.         SEGINI ,PMATG
  98.         CALL MATG(G)
  99.       ENDIF
  100.       SEGINI,PTRA23
  101. C
  102.       NELTA=0
  103.       DO NSMA=1,N1
  104. C     ----------------------------------------------------------
  105. C     On boucle sur les sous-objets MAILLAGE  -> NSMA
  106. C
  107.          NSPA1=1
  108.          IF (ICOQ.AND.KQUAD(NSMA)) NSPA1=2
  109.  
  110.          IMODE1 = MYMOD.KMODEL(NSMA)
  111.          ISSMA = IMODE1.IMAMOD
  112.  
  113.          NSGEO1= ISSMA.NUM(/1)
  114. C**        NAM   = ISSMA.NUM(/1)
  115.          IF (IDIM.EQ.2) THEN
  116.            NAM=2
  117.          ELSE
  118.            NAM=NSGEO1
  119.            IF (ICOQ.AND.KQUAD(NSMA)) NAM=NSGEO1/2
  120.          ENDIF
  121.  
  122.          NNELMA = ISSMA.NUM(/2)
  123. C
  124.          DO NELMA=1,NNELMA
  125. C        ------------------------------------------------------
  126.            KA = NELMA + NELTA
  127.            PLIG = LFACT(KA)
  128.  
  129. C          On boucle sur les éléments de NSMA  -> NELMA
  130. C          Remplissage du tableau AM
  131.            DO I=1, NSGEO1, NSPA1
  132.              LS=I
  133.              IF (ICOQ.AND.KQUAD(NSMA)) LS=(I+1)/2
  134. C            On boucle sur les noeuds de NELMA
  135.                 IG = ISSMA.NUM(I,NELMA)
  136. C**             NYA(I) = IG
  137.                 NYA(LS) = IG
  138.                 IREF = (IDIM+1)*(IG-1)
  139.                 IF(IIMPI.GE.4)  WRITE(3,*) ' NELMA I ',NELMA,I
  140.                 DO K=1,IDIM
  141.                   AM(K,LS)=XCOOR(IREF+K)
  142.                 ENDDO
  143.                 IF(IIMPI.GE.4)    WRITE(3,*) ' AM ',(AM(K,LS),K=1,IDIM)
  144.            ENDDO
  145. C
  146. C
  147. C            Calcul de la normale->UA et de la surface->SA
  148. C            ( SS ne sert pas )
  149.              IF (IDIM.EQ.3) THEN
  150.                  CALL KNORM(IDIM,AM,NAM,UA,SA)
  151.              ELSE
  152.                  CALL KNORM2(IDIM,AM,NAM,UA,SA)
  153.              ENDIF
  154. C
  155.              PSUR.FACT(KA) = SA
  156. C
  157.              IF (IIMPI.GE.4) THEN
  158.                 WRITE (6,*) 'SURFACE DE L ELEMENT',NELMA,' : ',SA
  159.                 WRITE (6,*) 'normale ',(UA(K),K=1,IDIM)
  160.              ENDIF
  161. C
  162.              NELTB=0
  163.              DO NSMB=1,N1
  164. C            ----------------------------------------------------
  165. C            On boucle sur les sous-objets MAILLAGE  -> NSMB
  166.  
  167.              NSPA2=1
  168.              IF (ICOQ.AND.KQUAD(NSMB)) NSPA2=2
  169.  
  170.                 IMODE2 = MYMOD.KMODEL(NSMB)
  171.                 ISSMB = IMODE2.IMAMOD
  172.  
  173.                 NSGEO2 = ISSMB.NUM(/1)
  174. C**             NBM    = ISSMB.NUM(/1)
  175.                 IF (IDIM.EQ.2) THEN
  176.                   NBM=2
  177.                 ELSE
  178.                 NBM=NSGEO2
  179.                 IF (ICOQ.AND.KQUAD(NSMB)) NBM=NSGEO2/2
  180.                 ENDIF
  181.                 NNELMB  = ISSMB.NUM(/2)
  182. C
  183.                 DO NELMB=1,NNELMB
  184. C               -------------------------------------------------
  185.                 KB = NELMB + NELTB
  186.  
  187. C               On boucle sur les éléments de NSMB  -> NELMB
  188. C
  189. C              ****On regarde si l'on ne traite pas le même élément
  190.                    IF   ((NSMA.EQ.NSMB).AND.(NELMA.EQ.NELMB)) THEN
  191.                         FF = 0.D0
  192.                    ELSE
  193.                      DO I=1, NSGEO2, NSPA2
  194.                      LS=I
  195.                      IF (ICOQ.AND.KQUAD(NSMB)) LS=(I+1)/2
  196. C                  On boucle sur les noeuds de NELMB
  197. C
  198.                       IG = ISSMB.NUM(I,NELMB)
  199. C**                   NYB(I) = IG
  200.                       NYB(LS) = IG
  201.                       IREF = (IDIM+1)*(IG-1)
  202.                       IF(IIMPI.GE.4)  WRITE(6,*) ' NELMB I ',NELMB,I
  203.                       DO K=1,IDIM
  204. C**                     BM(K,I)=XCOOR(IREF+K)
  205.                         BM(K,LS)=XCOOR(IREF+K)
  206.                       ENDDO
  207.                   IF(IIMPI.GE.4)   WRITE(6,*) ' BM ',(BM(K,LS),K=1,IDIM)
  208. C
  209.                      ENDDO
  210. C
  211. C                  *****Calcul de la normale à NELMB -> UB
  212.                         IF (IDIM.EQ.3) THEN
  213.                             CALL KNORM(IDIM,BM,NBM,UB,SS)
  214.                         ELSE
  215.                             CALL KNORM2(IDIM,BM,NBM,UB,SS)
  216.                         ENDIF
  217. C
  218.                         PS = 0.D0
  219.                         DO K=1,IDIM
  220.                            PS = PS + UA(K)*UB(K)
  221.                         ENDDO
  222. C
  223.                         IF   (PS.LT.(0.995)) THEN
  224.                             IF (IDIM.EQ.3) THEN
  225.                     CALL CAL2S3(G,NAM,AM,NBM,BM,NGAUSS,FF,NYA,NYB,EDIS)
  226.                              ELSE
  227.                     CALL CAL2S2(NAM,AM,NBM,BM,FF)
  228.                              ENDIF
  229. C
  230.                              IF (FF.LT.1.D-6) THEN
  231.                                 MALEUR = .TRUE.
  232. C**                             GOTO 60
  233.                              ENDIF
  234. C
  235.                              FF = FF/SA
  236.                         ELSE
  237.                              FF = 0.D0
  238.                         ENDIF
  239.                    PLIG.FACT(KB) = FF
  240. C
  241.                    ENDIF
  242. C
  243.                 ENDDO
  244. C               fin NELMB ----------------------------------------
  245.                 NELTB=NELTB+NNELMB
  246. C
  247.              ENDDO
  248. C            fin NSMB --------------------------------------------
  249. C
  250.            ENDDO
  251. C          fin NELMA ---------------------------------------------
  252.            NELTA=NELTA+NNELMA
  253. C
  254.         ENDDO
  255. C       fin NSMA -------------------------------------------------
  256. C
  257.         SEGSUP PTRA23
  258.         IF (IDIM.EQ.3) THEN
  259.            SEGSUP PMATG
  260.         ENDIF
  261.  
  262.    60   CONTINUE
  263.         IF (MALEUR.EQV..TRUE.) THEN
  264.         WRITE (6,*) 'verifiez l orientation des elements'
  265.         ENDIF
  266. C
  267. C>>>  CACUL DES BILANS ET IMPRESSION (pas de normalisation en convexe)
  268. C     ------------------------------
  269.        INOR=0
  270.        CALL KFN(IFACFO,INOR,KIMP)
  271.  
  272. C     Traduction puis suppression de IFACFO
  273.  
  274.       IF (KIMP.GE.3) THEN
  275.       CALL PRFACF(IFACFO)
  276.       ENDIF
  277.  
  278.       LTITR=1
  279.       INFOEL=0
  280.       CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  281.  
  282.       SEGACT IFACFO
  283.       DO 930 LS=1,NNBEL1
  284.         PLIG=LFACT(LS)
  285.         SEGSUP PLIG
  286.  930  CONTINUE
  287.       PSUR = LFACT(NNBEL1)
  288.       SEGSUP IFACFO
  289.  
  290.       END
  291.  
  292.  
  293.  

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