Télécharger la plaquette Cast3M


fr en

Télécharger facgen.eso

Retour à la liste

Numérotation des lignes : 

facgen

  1. C FACGEN    SOURCE    OF166741  24/10/03    21:15:12     12022          
  2.       SUBROUTINE FACGEN (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC
  3.      &                  ,EXTINC)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6. C----------------------------------------------------------------------
  7. C     03/96 l'hemicube est defini dans le repere local a la face "1"
  8. C
  9. C     Calcul des facteurs de forme OPTION CACHE 3D
  10. C     SP APPELE PAR FACFOR
  11. C  entree:
  12. C     MYMOD  : objet modèle
  13. C     INFOEL : segment décrivant la nature des éléments des maillages
  14. C     LRES   : parametre de resolution
  15. C     XDEC   : parametre de decoupage
  16. C     IAXE   : pointeur sur le LISTEN contenant les pointeurs des
  17. C              points definissant le plan de symetrie
  18. C     INOR   : parametre de normalisation et impression
  19. C  sortie:
  20. C     ICHFAC : chamelem facteur de forme
  21. C----------------------------------------------------------------------
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC SMCOORD
  26.       POINTEUR MYMOD.MMODEL
  27. -INC TFFOR3D
  28. C--------------------------------------------------------------
  29. C     FACTEURS DE FORME
  30. C           NNBEL1 = NOMBRE DE LIGNES + 1
  31. C           NBEL2  = NOMBRE DE COLONNES
  32. C     LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
  33. C
  34.       SEGMENT IFACFO
  35.        INTEGER   LFACT(NNBEL1)
  36.       ENDSEGMENT
  37.       SEGMENT LFAC
  38.        REAL*8    FACT(NBEL2)
  39.       ENDSEGMENT
  40.       POINTEUR PSUR.LFAC, PLIG.LFAC
  41.       POINTEUR PCOL.LFAC
  42. C--------------------------------------------------------------
  43.       SEGMENT SPROGP
  44.       INTEGER  MKF(MPT),MICOO(2,MPT)
  45.       REAL*8   MXR(3,MPT)
  46.       ENDSEGMENT
  47. C--------------------------------------------------------------
  48.       SEGMENT SKCEL
  49.       INTEGER  KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC)
  50.       REAL*8   RMAX
  51.       ENDSEGMENT
  52. C--------------------------------------------------------------
  53. C     segment qui va contenir les coordonnées du plan de symétrie
  54.       SEGMENT ,LISTEN
  55.         INTEGER LECT(NBE)
  56.       ENDSEGMENT
  57.       POINTEUR IAXE.LISTEN
  58. C--------------------------------------------------------------
  59. C
  60.       DIMENSION U1(4),U2(4)
  61.       DIMENSION O1(3)
  62.       DIMENSION A1(3,3),A2(3,3)
  63.       DIMENSION UA(3),UN(3),UU2(4),AA2(3,3)
  64. C**   changement de repere
  65.       DIMENSION HCM(3,3),OH(3),AH1(3,3),UH1(4)
  66.       DIMENSION AH2(3,3),UH2(4),AAH2(3,3),UUH2(4)
  67. C
  68. C--------------------------------------------------------------
  69. C
  70. *     Definition du common CKRESO
  71.       KFC=6
  72.       NRES = LRES
  73.       KES  = IDIM
  74.       KIMP = IIMPI
  75.       NSOM=3
  76.  
  77. C
  78. C-----PLAN DE SYMETRIE-----------------------------------------------
  79.       IF (IAXE.NE.0) THEN
  80. C     A partir des trois points definissant le plan , on va garder
  81. C       une normale et le premier point
  82.       IF (IIMPI.GE.1) THEN
  83.         WRITE(6,*) ' CALCUL AVEC PLAN DE SYMETRIE '
  84.       ENDIF
  85.       DO 100 IP= 1,NSOM
  86. C     On boucle sur les points
  87.          IREF = (IDIM+1)*(IAXE.LECT(IP)-1)
  88.          DO 101 IIES= 1,IDIM
  89. C        On boucle sur les coordonnées
  90.              A1(IIES,IP) = XCOOR(IREF+IIES)
  91. C            (boucle : pas de défaut de page pour un tableau 3*3 de réels)
  92.  101     CONTINUE
  93.  100  CONTINUE
  94.       CALL KNORM(IDIM,A1,IDIM,U1,SSS)
  95.       DO 102 IIES = 1,IDIM
  96.       UA(IIES) = A1(IIES,1)
  97.       UN(IIES) = U1(IIES)
  98.  102  CONTINUE
  99.         IF(KIMP.GE.2) THEN
  100.         WRITE(6,*) '  plan de symetrie '
  101.         WRITE(6,*) '  point   ',(UA(I),I=1,IDIM)
  102.         WRITE(6,*) '  normale ',(UN(I),I=1,IDIM)
  103.         ENDIF
  104.       ENDIF
  105.  
  106. C-----PLAN DE SYMETRIE-----------------------------------------------
  107.  
  108.       EPS = 1D-5
  109. C
  110. C>>>  PREPARATION
  111. C
  112.       CALL KALPRE(MYMOD,INFOEL,SKFACE,XDEC,NELD)
  113. C
  114. C>>>  INITIALISATION DES OBJETS DE TRAVAIL
  115. C
  116.  
  117.       NBEL1 = NELD
  118.       NNBEL1 = NELD+1
  119.       NBEL2 = NELD
  120.       SEGINI IFACFO
  121.  
  122.       DO 900 LS=1,NNBEL1
  123.          SEGINI PLIG
  124.          LFACT(LS) = PLIG
  125.          SEGDES PLIG
  126.  900  CONTINUE
  127.  
  128.       PSUR = LFACT(NNBEL1)
  129.       SEGACT PSUR*MOD
  130.  
  131.       SEGACT SKFACE*MOD
  132.       MFACE = NUK(/2)
  133.       DO 910 K1 = 1,MFACE
  134.          I1 = KCORR(K1)
  135.          PSUR.FACT(I1) = PSUR.FACT(I1) + S(K1)
  136.  910  CONTINUE
  137.  
  138.       NR=NRES
  139.       NES=KES
  140.       NFC=KFC
  141.       SEGINI SHC3D
  142.       IF(KIMP.GE.2) THEN
  143.         WRITE(6,*) ' SHC3D ',SHC3D
  144.       ENDIF
  145.       CALL KCACUB(NES,NR,G,V,NFC,KRO,KSI,IR)
  146.       CALL KHCDAT(NR,KA,IM)
  147.  
  148.       NSTAC = NR*NR
  149.       SEGINI SKCEL
  150.  
  151.       NFC = KRO(/1)
  152.       NOC = 8
  153.       RMAX = 0.9
  154.       SEGINI SKBUFF
  155.  
  156.       MPT = 3
  157.       SEGINI SPROGP
  158.  
  159.       NSE = 3
  160.       NIMAX = 10*NR
  161.       NSCEL = NIMAX
  162.       SEGINI SPROJA
  163.  
  164. C     CALCUL
  165. C     ------
  166.  
  167.       CALL KFALIM(MFACE,K1D,K1F)
  168.       DO 300  K1 = K1D,K1F
  169.  
  170.         I1 = KCORR(K1)
  171.         IF (IIMPI.GE.4) WRITE(6,*) 'La facette',K1,
  172.      #          'appartient à l élmt',I1
  173.         PLIG = LFACT(I1)
  174.         SEGACT PLIG*MOD
  175.  
  176.         SREL = S(K1)/PSUR.FACT(I1)
  177.  
  178.         DO 312 K=1,IDIM+1
  179.         U1(K) = U(K,K1)
  180.  312    CONTINUE
  181.  
  182.          DO 201 ISS = 1,NSOM
  183.             IREF = (IDIM+1)*(NUK(ISS,K1)-1)
  184.             DO 202 K = 1,IDIM
  185.             A1(K,ISS) = XCOOR(IREF+K)
  186.  202        CONTINUE
  187.  201     CONTINUE
  188.  
  189. C** repere local a l'HC
  190.  
  191.         CALL KREPER(IDIM,NSOM,U1,A1,HCM)
  192.  
  193.         IPATCH = KPATCH(K1)
  194.         SEGACT IPATCH
  195.  
  196.         NPATCH = GP(/2)
  197.  
  198.           CALL KTYPKS(NPATCH,KS1D,KS1F)
  199.           DO 310 KS1 = KS1D,KS1F
  200.           IF (IIMPI.GE.4) WRITE(6,*) ' K1 KS1 NPATCH ',K1,KS1,NPATCH
  201.  
  202.               DO 311 K=1,IDIM
  203.               O1(K) = GP(K,KS1)
  204.  311          CONTINUE
  205.               IF (IIMPI.GE.4) WRITE(6,*) K1,
  206.      #                          KS1,' O1 ',(O1(I1),I1=1,IDIM)
  207.  
  208.               CALL KINBUF(SKBUFF)
  209. C
  210. C     O1 est le point de vue sur la surface 1
  211.  
  212. C    coordonnées dans le repere local
  213.               OH(1)=0.D0
  214.               OH(2)=0.D0
  215.               OH(3)=0.D0
  216.  
  217.               CALL KCHREP(IDIM,NSOM,O1,A1,U1,AH1,UH1,HCM)
  218.  
  219.               CALL KINPRO(UH1,SHC3D,SKBUFF)
  220.  
  221.               CALL KVERIF(SHC3D,SKBUFF)
  222.  
  223. C    2eme boucle sur les faces
  224. C    -------------------------
  225. C       RAPPEL:
  226. C       CAS TRAITES   KVU = 1                    : TRAITEMENT COMMUN
  227. C                     KVU = 2  ET KSIG..=1         -----------------
  228. C
  229.             DO 400 K2 = 1,MFACE
  230.  
  231.             IF(KIMP.GE.4) THEN
  232.             write(6,*)
  233.             write(6,*) ' K1 K2 ',K1,K2
  234.             ENDIF
  235. C
  236.               DO 412 K=1,IDIM+1
  237.               U2(K) = U(K,K2)
  238.  412          CONTINUE
  239.  
  240.             DO 211 ISS = 1,NSOM
  241.                IREF = (IDIM+1)*(NUK(ISS,K2)-1)
  242.                DO 212 K = 1,IDIM
  243.                A2(K,ISS) = XCOOR(IREF+K)
  244.  212           CONTINUE
  245.  211        CONTINUE
  246.  
  247. C     coordonnées dans le repere local
  248.       CALL KCHREP(IDIM,NSOM,O1,A2,U2,AH2,UH2,HCM)
  249.  
  250. CNNN------SEQUENCE POUR LA FACE K2---------------------------------
  251. C
  252. C>>>  VISIBILITE A PRIORI
  253. C
  254. C**     CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU)
  255.         CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AH2,UH1,UH2,KVU)
  256. C
  257.       IF (KVU.NE.0) THEN
  258. C**          C = U2(IDIM+1)
  259.              C = UH2(IDIM+1)
  260. C            DO 401  IIES = 1,IDIM
  261. C**          C = C + U2(IIES)*O1(IIES)
  262. C inutile    C = C + UH2(IIES)*OH(IIES)
  263. C401         CONTINUE
  264.  
  265.        IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1))  THEN
  266. C**    CALL KPROJF(O1,A2,K1,K2,C,U2,SHC3D,SKCEL,SKBUFF,SPROGA,SPROGP)
  267.        CALL KPROJF(OH,AH2,K1,K2,C,UH2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  268.  
  269.        ENDIF
  270.  
  271.       ENDIF
  272.  
  273. CNNN--FIN SEQUENCE POUR LA FACE K2---------------------------------
  274. C
  275.       IF (IAXE.NE.0) THEN
  276.  
  277. CNNN------SEQUENCE POUR LA FACE SYMETRIQUE DE K2 ------------------
  278. C         LE PLAN SE SYMETRIE EST DEFINI PAR UN POINT UA
  279. C                                            UNE NORMALE UNITAIRE UN
  280. C         CALCUL DES SYMETRIQUES DE U2 ET A2(SOMMETS)
  281. C
  282.           KES1 = IDIM + 1
  283.           CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN)
  284.  
  285. C     coordonnées dans le repere local
  286.           CALL KCHREP(IDIM,NSOM,O1,AA2,UU2,AAH2,UUH2,HCM)
  287.  
  288. C**       CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU)
  289.           CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AAH2,UH1,UUH2,KVU)
  290.  
  291.       IF (KVU.NE.0) THEN
  292. C**          C = UU2(IDIM+1)
  293.              C = UUH2(IDIM+1)
  294. CC           DO 402  IIES = 1,IDIM
  295. C**          C = C + UU2(IIES)*O1(IIES)
  296. C inutile    C = C + UUH2(IIES)*OH(IIES)
  297. C402         CONTINUE
  298.  
  299.         IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1))  THEN
  300. C**     CALL KPROJF(O1,AA2,K1,K2,C,UU2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  301.         CALL KPROJF(OH,AAH2,K1,K2,C,UUH2
  302.      &         ,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  303.         ENDIF
  304.  
  305.       ENDIF
  306.  
  307. CNNN--FIN SEQUENCE POUR LA FACE SYMETRIQUE DE K2-------------------
  308.  
  309.       ENDIF
  310.  400      CONTINUE
  311. C
  312. C>>> RECOMBINAISON
  313. C
  314.       SSP1 = SP(KS1)
  315.       CALL KRCOMB(K1,SSP1,SHC3D,SKFACE,SKBUFF,EXTINC)
  316.  
  317.       IF (K1F.NE.MFACE) THEN
  318.         FFFT = 0.D0
  319.         DO 420 K2=1,MFACE
  320.         FFFT = FFFT + FF1(K2)
  321.  420    CONTINUE
  322.         WRITE(6,*) ' '
  323.         WRITE(6,*) ' FIJ RELATIF A LA FACE (TRI3) ',K1,'   SOMME ',FFFT
  324.         CALL UTPRIM(FF1,MFACE)
  325.       ENDIF
  326.  
  327.         DO 920 K2 = 1,MFACE
  328.         I2 = KCORR(K2)
  329.         PLIG.FACT(I2) = PLIG.FACT(I2) + FF1(K2)*SREL
  330.  920    CONTINUE
  331.  
  332.  310    CONTINUE
  333.  
  334.         SEGDES PLIG
  335.         SEGDES IPATCH
  336.  300  CONTINUE
  337. C
  338. C     -------------------------------------------------------------
  339. C
  340.       SEGDES IFACFO
  341.       SEGDES PSUR
  342. C
  343.       SEGSUP ,SHC3D,SKCEL,SKBUFF
  344.       SEGSUP ,SPROGP,SPROJA
  345.       SEGSUP SKFACE
  346. C
  347.       IF (K1D.NE.1.AND.K1F.NE.MFACE) CALL ARRET(0)
  348. C
  349. C>>>  NORMALISATION ET SYMETRISATION
  350. C     ------------------------------
  351.  
  352.       IF(EXTINC.GT.1D-3) THEN
  353.          INOR=0
  354.       ENDIF
  355.  
  356.       CALL KFN(IFACFO,INOR,KIMP)
  357.  
  358.       IF(KIMP.GE.3) THEN
  359.        CALL PRFACF(IFACFO)
  360.       ENDIF
  361. C
  362. C
  363. C>>>  TRADUCTION
  364. C     ----------
  365.       LTITR=1
  366.       CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  367. C
  368. C     Destruction de IFACFO après traduction
  369.       SEGACT IFACFO
  370.       NNBEL1 = LFACT(/1)
  371.       DO 950 NN = 1,NNBEL1
  372.          PLIG = LFACT(NN)
  373.          SEGSUP PLIG
  374.  950  CONTINUE
  375.       SEGSUP IFACFO
  376.  
  377.       RETURN
  378.       END
  379.  
  380.  
  381.  

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