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

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