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    CB215821  24/04/12    21:15:54     11897          
  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.  
  70.         SEGACT MYMOD
  71. C
  72. C     Calcul du nombre de faces NFACE et activation de maillages
  73. C
  74.       SEGACT MYMOD
  75.       N1 = MYMOD.KMODEL(/1)
  76.           NFACE = 0
  77.           DO 10 ITYP=1,N1
  78.           IMODEL = MYMOD.KMODEL(ITYP)
  79.           SEGACT IMODEL
  80.           IPT1 = IMAMOD
  81.           SEGACT IPT1
  82.           NEL = IPT1.NUM(/2)
  83.           NFACE = NFACE + NEL
  84.   10      CONTINUE
  85. C
  86. C>>>  INITIALISATION OBJET FACFOR
  87. C     ---------------------------
  88. C
  89.       NNBEL1=NFACE+1
  90.       NBEL2=NFACE
  91.       SEGINI IFACFO
  92.       DO 900 LS=1,NNBEL1
  93.       SEGINI PLIG
  94.       LFACT(LS)=PLIG
  95.       SEGACT PLIG*MOD
  96.  900  CONTINUE
  97.       PSUR = LFACT(NNBEL1)
  98.       SEGACT PSUR*MOD
  99.  
  100. C     -------------------------------------------------------------
  101. C
  102.         IF (IDIM.EQ.3) THEN
  103.            SEGINI ,PMATG
  104.            CALL MATG(G)
  105.         ENDIF
  106.         SEGINI ,PTRA23
  107. C
  108. C
  109.         NELTA=0
  110.         DO NSMA=1,N1
  111. C       ----------------------------------------------------------
  112. C       On boucle sur les sous-objets MAILLAGE  -> NSMA
  113. C
  114.            NSPA1=1
  115.            IF (ICOQ.AND.KQUAD(NSMA)) NSPA1=2
  116.  
  117.            IMODE1 = MYMOD.KMODEL(NSMA)
  118.            ISSMA = IMODE1.IMAMOD
  119.  
  120.            NSGEO1= ISSMA.NUM(/1)
  121. C**        NAM   = ISSMA.NUM(/1)
  122.            IF (IDIM.EQ.2) THEN
  123.              NAM=2
  124.            ELSE
  125.              NAM=NSGEO1
  126.              IF (ICOQ.AND.KQUAD(NSMA)) NAM=NSGEO1/2
  127.            ENDIF
  128.  
  129.            NNELMA = ISSMA.NUM(/2)
  130. C
  131.            DO NELMA=1,NNELMA
  132. C          ------------------------------------------------------
  133.            KA = NELMA + NELTA
  134.            PLIG = LFACT(KA)
  135.  
  136. C          On boucle sur les éléments de NSMA  -> NELMA
  137. C
  138. C            Remplissage du tableau AM
  139.              DO I=1, NSGEO1, NSPA1
  140.              LS=I
  141.              IF (ICOQ.AND.KQUAD(NSMA)) LS=(I+1)/2
  142. C            On boucle sur les noeuds de NELMA
  143.                 IG = ISSMA.NUM(I,NELMA)
  144. C**             NYA(I) = IG
  145.                 NYA(LS) = IG
  146.                 IREF = (IDIM+1)*(IG-1)
  147.                 IF(IIMPI.GE.4)  WRITE(3,*) ' NELMA I ',NELMA,I
  148.                 DO K=1,IDIM
  149. C**                AM(K,I)=XCOOR(IREF+K)
  150.                    AM(K,LS)=XCOOR(IREF+K)
  151.                 ENDDO
  152.                 IF(IIMPI.GE.4)    WRITE(3,*) ' AM ',(AM(K,LS),K=1,IDIM)
  153.              ENDDO
  154. C
  155. C
  156. C            Calcul de la normale->UA et de la surface->SA
  157. C            ( SS ne sert pas )
  158.              IF (IDIM.EQ.3) THEN
  159.                  CALL KNORM(IDIM,AM,NAM,UA,SA)
  160.              ELSE
  161.                  CALL KNORM2(IDIM,AM,NAM,UA,SA)
  162.              ENDIF
  163. C
  164.              PSUR.FACT(KA) = SA
  165. C
  166.              IF (IIMPI.GE.4) THEN
  167.                 WRITE (6,*) 'SURFACE DE L ELEMENT',NELMA,' : ',SA
  168.                 WRITE (6,*) 'normale ',(UA(K),K=1,IDIM)
  169.              ENDIF
  170. C
  171.              NELTB=0
  172.              DO NSMB=1,N1
  173. C            ----------------------------------------------------
  174. C            On boucle sur les sous-objets MAILLAGE  -> NSMB
  175.  
  176.              NSPA2=1
  177.              IF (ICOQ.AND.KQUAD(NSMB)) NSPA2=2
  178.  
  179.                 IMODE2 = MYMOD.KMODEL(NSMB)
  180.                 ISSMB = IMODE2.IMAMOD
  181.  
  182.                 NSGEO2 = ISSMB.NUM(/1)
  183. C**             NBM    = ISSMB.NUM(/1)
  184.                 IF (IDIM.EQ.2) THEN
  185.                   NBM=2
  186.                 ELSE
  187.                 NBM=NSGEO2
  188.                 IF (ICOQ.AND.KQUAD(NSMB)) NBM=NSGEO2/2
  189.                 ENDIF
  190.                 NNELMB  = ISSMB.NUM(/2)
  191. C
  192.                 DO NELMB=1,NNELMB
  193. C               -------------------------------------------------
  194.                 KB = NELMB + NELTB
  195.  
  196.  
  197. C               On boucle sur les éléments de NSMB  -> NELMB
  198. C
  199. C              ****On regarde si l'on ne traite pas le même élément
  200.                    IF   ((NSMA.EQ.NSMB).AND.(NELMA.EQ.NELMB)) THEN
  201.                         FF = 0.D0
  202.                    ELSE
  203.                      DO I=1, NSGEO2, NSPA2
  204.                      LS=I
  205.                      IF (ICOQ.AND.KQUAD(NSMB)) LS=(I+1)/2
  206. C                  On boucle sur les noeuds de NELMB
  207. C
  208.                       IG = ISSMB.NUM(I,NELMB)
  209. C**                   NYB(I) = IG
  210.                       NYB(LS) = IG
  211.                       IREF = (IDIM+1)*(IG-1)
  212.                       IF(IIMPI.GE.4)  WRITE(6,*) ' NELMB I ',NELMB,I
  213.                       DO K=1,IDIM
  214. C**                     BM(K,I)=XCOOR(IREF+K)
  215.                         BM(K,LS)=XCOOR(IREF+K)
  216.                       ENDDO
  217.                   IF(IIMPI.GE.4)   WRITE(6,*) ' BM ',(BM(K,LS),K=1,IDIM)
  218. C
  219.                      ENDDO
  220. C
  221. C                  *****Calcul de la normale à NELMB -> UB
  222.                         IF (IDIM.EQ.3) THEN
  223.                             CALL KNORM(IDIM,BM,NBM,UB,SS)
  224.                         ELSE
  225.                             CALL KNORM2(IDIM,BM,NBM,UB,SS)
  226.                         ENDIF
  227. C
  228. C
  229.                         PS = 0.D0
  230.                         DO K=1,IDIM
  231.                            PS = PS + UA(K)*UB(K)
  232.                         ENDDO
  233. C
  234.                         IF   (PS.LT.(0.995)) THEN
  235.                             IF (IDIM.EQ.3) THEN
  236.                     CALL CAL2S3(G,NAM,AM,NBM,BM,NGAUSS,FF,NYA,NYB,EDIS)
  237.                              ELSE
  238.                     CALL CAL2S2(NAM,AM,NBM,BM,FF)
  239.                              ENDIF
  240. C
  241.                              IF (FF.LT.1.D-6) THEN
  242.                                 MALEUR = .TRUE.
  243. C**                             GOTO 60
  244.                              ENDIF
  245. C
  246.                              FF = FF/SA
  247.                         ELSE
  248.                              FF = 0.D0
  249.                         ENDIF
  250.                    PLIG.FACT(KB) = FF
  251. C
  252.                    ENDIF
  253. C
  254.                 ENDDO
  255. C               fin NELMB ----------------------------------------
  256.                 NELTB=NELTB+NNELMB
  257. C
  258.              ENDDO
  259. C            fin NSMB --------------------------------------------
  260. C
  261.            ENDDO
  262. C          fin NELMA ---------------------------------------------
  263.            NELTA=NELTA+NNELMA
  264. C
  265.         ENDDO
  266. C       fin NSMA -------------------------------------------------
  267. C
  268. C
  269.         SEGSUP PTRA23
  270.         IF (IDIM.EQ.3) THEN
  271.            SEGSUP PMATG
  272.         ENDIF
  273. C
  274.  
  275.    60   CONTINUE
  276.         IF (MALEUR.EQV..TRUE.) THEN
  277.         WRITE (6,*) 'verifiez l orientation des elements'
  278.         ENDIF
  279.  
  280. C
  281. C>>>  CACUL DES BILANS ET IMPRESSION (pas de normalisation en convexe)
  282. C     ------------------------------
  283.        INOR=0
  284.        CALL KFN(IFACFO,INOR,KIMP)
  285.  
  286. C     Traduction puis suppression de IFACFO
  287.  
  288.       IF (KIMP.GE.3) THEN
  289.       CALL PRFACF(IFACFO)
  290.       ENDIF
  291.  
  292.       DO 920 ITYP = 1,N1
  293.          IMODEL = MYMOD.KMODEL(ITYP)
  294.          SEGACT IMODEL
  295.          IPT1 = IMAMOD
  296.  920  CONTINUE
  297.  
  298.       LTITR=1
  299.       INFOEL=0
  300.       CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  301.  
  302.       SEGACT IFACFO
  303.       DO 930 LS=1,NNBEL1
  304.       PLIG=LFACT(LS)
  305.       SEGSUP PLIG
  306.  930  CONTINUE
  307.       PSUR = LFACT(NNBEL1)
  308.       SEGSUP IFACFO
  309.  
  310.       END
  311.  
  312.  
  313.  
  314.  

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