Télécharger la plaquette Cast3M


fr en

Télécharger facge2.eso

Retour à la liste

Numérotation des lignes : 

facge2

  1. C FACGE2    SOURCE    OF166741  24/10/03    21:15:12     12022          
  2.       SUBROUTINE FACGE2 (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC
  3.      &                   ,EXTINC)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6. *----------------------------------------------------------------------
  7. *     Calcul des facteurs de forme OPTION CACHE 2D-plan
  8. *     SP APPELE PAR FFORME
  9. *   entrée
  10. *     MYMOD  : objet modèle
  11. *     INFOEL : segment décrivant la nature des éléments des maillages
  12. *     LRES   : parametre de resolution
  13. *     XDEC   : parametre de decoupage
  14. *     IAXE   : pointeur sur le chamtrio decrivant le plan de symetrie
  15. *     INOR   : parametre de normalisation et impression
  16. *     EXTINC : coefficient d'extinction si cavite absorbante
  17. *   sortie
  18. *     ICHFAC : chamelem facteur de forme
  19. *----------------------------------------------------------------------
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMCOORD
  24. -INC SMELEME
  25.  
  26. C----------------------------------------------------------------------
  27. C     segment qui va contenir les coordonnées du plan de symétrie
  28.       SEGMENT,LISTEN
  29.         INTEGER LECT(NBE)
  30.       ENDSEGMENT
  31.       POINTEUR IAXE.LISTEN
  32.  
  33. C-----------------------------------------------------------------------
  34.       SEGMENT SKRESO
  35.         INTEGER KFC,NRES,KES,KIMP
  36.       ENDSEGMENT
  37. C     KFC : NOMBRE DE FACES H.C
  38. C     NRES: RESOLUTION
  39. C     KES : DIM ESPACE
  40. C     KIMP: IMPRESSION
  41. C-----------------------------------------------------------------------
  42.       SEGMENT SKFAC2
  43.       INTEGER  NUK(MS,MFACE),KPATCH(MFACE)
  44.       INTEGER  NCELL(MFACE)
  45.       REAL*8   U(3,MFACE),S(MFACE)
  46.       REAL*8  FF1(MFACE)
  47.       ENDSEGMENT
  48.       SEGMENT IPATCH
  49.       REAL*8   GP(MSP,NPATCH),SP(NPATCH)
  50.       ENDSEGMENT
  51. C
  52. C     DESCRIPTION DES ELEMENTS
  53. C     ------------------------
  54. C     MFACE : NOMBRE DE FACES
  55. C     NUK   : CONNECTIVITES
  56. C     U     : NORMALE UNITAIRE ET EQUATION DU PLAN DE L'ELEMENT
  57. C     S     : SURFACE
  58. C     KVU   : VISIBILITE A PRIORI
  59. C     FF    : FACTEURS DE FORME
  60. C     FF1   : TRAVAIL
  61. C     NCELL : NOMBRE TOTAL DE CELLULES VUES PAR UN POINT
  62. C     KPATCH: POINTEUR SUR IPATCH
  63. C     NPATCH: NOMBRE DE POINTS SUR L'ELEMENT (REDECOUPAGE)
  64. C     GP    : COORDONNEES DES POINTS
  65. C     SP    : ET SURFACES
  66. C-----------------------------------------------------------------------
  67.       SEGMENT SHC2D
  68.       INTEGER IR(NR),KA(NFC),IM(NFC,NFC)
  69.       INTEGER KRO(NFC,NES),KSI(NFC,NES)
  70.       REAL*8  V(NES,NR),G(NR)
  71.       ENDSEGMENT
  72.  
  73. C     DESCRIPTION DU H.C DE PROJECTION
  74. C     --------------------------------
  75. C     V : DIRECTION UNITAIRE DES CELLULES
  76. C     G : FACTEUR DE FORME ASSOCIE
  77. C     IR: CORRESPONDANCE
  78. C     KRO , KSI : POUR LE CHANGEMENT DE REPERE
  79. C     IM  : REFERENCE
  80. C     NR  : RESOLUTION
  81. C     NFC : NOMBRE DE FACES
  82. C-----------------------------------------------------------------------
  83.       SEGMENT SKBUF2
  84.       INTEGER  NUMF(NFC,NOC,NR),NTYP(NFC,NR)
  85.       REAL*8   ZB(NFC,NR),PSC(NFC,NR)
  86.       ENDSEGMENT
  87. C
  88. C     BUFFER ASSOCIE AU H.C
  89. C     ---------------------
  90. C     NUMF : INDICE DE LE DERNIERE FACE RENCONTREE
  91. C     NTYP :  TYPES ASSOCIES
  92. C     ZB  : PROFONDEUR
  93. C     PSC  :  PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)
  94. C-----------------------------------------------------------------------
  95. C     FACTEURS DE FORME
  96. C           NNBEL1 = NOMBRE DE LIGNES + 1
  97. C           NBEL2  = NOMBRE DE COLONNES
  98. C     LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
  99. C
  100.       SEGMENT IFACFO
  101.        INTEGER   LFACT(NNBEL1)
  102.       ENDSEGMENT
  103.       SEGMENT LFAC
  104.        REAL*8    FACT(NBEL2)
  105.       ENDSEGMENT
  106.       POINTEUR PSUR.LFAC, PLIG.LFAC
  107.       POINTEUR PCOL.LFAC
  108. C----------------------------------------------------------------------
  109.       SEGMENT STRAV
  110.       REAL*8    U1(3),U2(3),O1(2)
  111.       REAL*8    A1(2,2),A2(2,2)
  112.       REAL*8    AA2(2,2),UU2(3),UA(2),UN(2)
  113.       ENDSEGMENT
  114. C----------------------------------------------------------------------
  115. *//////
  116. *      Mise à jour de variables SKRESO
  117.        SEGINI SKRESO
  118.        KES = IDIM
  119.        KIMP = IIMPI
  120.        NRES = LRES
  121.        KFC=4
  122. *//////
  123.       SEGINI STRAV
  124. C
  125. C
  126. CNN-----AXE DE SYMETRIE--------------------------------------------------
  127.       IF (IAXE.NE.0) THEN
  128.           IF(IIMPI.GE.1) THEN
  129.                WRITE(6,*) ' CALCUL AVEC AXE DE SYMETRIE '
  130.           ENDIF
  131. C         Numéro des 2 points définissant l'axe
  132.           IREF1 = (IDIM+1)*(IAXE.LECT(1)-1)
  133.           IREF2 = (IDIM+1)*(IAXE.LECT(2)-1)
  134. C         On garde un point ( UA ) et la normale ( UN )
  135.           UA(1) = XCOOR(IREF1+1)
  136.           UA(2) = XCOOR(IREF1+2)
  137.           UN(1) = UA(2) - XCOOR(IREF2+2)
  138.           UN(2) = XCOOR(IREF2+1) - UA(1)
  139.           DUN=SQRT(UN(1)*UN(1)+UN(2)*UN(2))
  140.           IF (DUN.LT.1.E-5) THEN
  141.               WRITE(6,*) ' LES POINTS DE L AXE SONT CONFONDUS '
  142.               CALL ARRET(0)
  143.               RETURN
  144.           ENDIF
  145.           UN(1) = UN(1)/DUN
  146.           UN(2) = UN(2)/DUN
  147.        ENDIF
  148. CNN------------------------------------------------------------------
  149.       NSOM = 2
  150.       EPS = 1E-5
  151. C
  152. C>>>  PREPARATION
  153. C
  154.       CALL KALPR2(MYMOD,INFOEL,SKFAC2,SHC2D,XDEC,NELD,SKRESO)
  155. C
  156. C>>>  INITIALISATION OBJET FACFOR
  157. C
  158.       NBEL1 = NELD
  159.       NNBEL1 = NELD+1
  160.       NBEL2 = NELD
  161.       SEGINI IFACFO
  162.  
  163.       DO 900 LS=1,NNBEL1
  164.       SEGINI PLIG
  165.       LFACT(LS) = PLIG
  166.       SEGDES PLIG
  167.  900  CONTINUE
  168.  
  169.       PSUR = LFACT(NNBEL1)
  170.       SEGACT PSUR*MOD
  171.       SEGACT SKFAC2
  172.       MFACE = NUK(/2)
  173.       DO 910 K1 = 1,MFACE
  174.         PSUR.FACT(K1) = PSUR.FACT(K1) + S(K1)
  175.  910  CONTINUE
  176.  
  177. C     -------------------------------------------------------------
  178. C>>>  CALCUL
  179. C
  180.       SEGACT SHC2D,SKFAC2*MOD
  181.       MFACE = NUK(/2)
  182.  
  183.       NR = IR(/1)
  184.       NFC = KRO(/1)
  185.       NOC = 4
  186.       SEGINI SKBUF2
  187.  
  188.       CALL KFALIM(MFACE,K1D,K1F)
  189.       DO 300  K1 = K1D,K1F
  190.  
  191.         PLIG = LFACT(K1)
  192.         SEGACT PLIG*MOD
  193.  
  194.         DO 312 K=1,IDIM+1
  195.            U1(K) = U(K,K1)
  196.  312    CONTINUE
  197.  
  198.          DO 201 ISS = 1,NSOM
  199.             IREF = (IDIM+1)*(NUK(ISS,K1)-1)
  200.             DO 202 K = 1,IDIM
  201.             A1(K,ISS) = XCOOR(IREF+K)
  202.  202        CONTINUE
  203.  201     CONTINUE
  204.  
  205.         CALL KINPR2(U1,SHC2D,SKBUF2,SKRESO)
  206.         CALL KVERI2(SHC2D,SKBUF2,SKRESO)
  207.  
  208.         IPATCH = KPATCH(K1)
  209.         SEGACT IPATCH
  210.         NPATCH = GP(/2)
  211.  
  212.           CALL KTYPKS(NPATCH,KS1D,KS1F)
  213.  
  214.           DO 310 KS1 = KS1D,KS1F
  215.  
  216.             DO 311 K=1,IDIM
  217.             O1(K) = GP(K,KS1)
  218.  311        CONTINUE
  219.             IF (IIMPI.GE.4) THEN
  220.                 WRITE(6,*) K1,KS1,' O1 ',(O1(I1),I1=1,IDIM)
  221.             ENDIF
  222.             CALL KINBU2(SKBUF2,SKRESO)
  223. C
  224. C    FACES
  225. C    -----
  226.           DO 400 K2 = 1,MFACE
  227.  
  228.             DO 412 K=1,IDIM+1
  229.             U2(K) = U(K,K2)
  230.  412        CONTINUE
  231.  
  232.             DO 211 ISS = 1,NSOM
  233.                IREF = (IDIM+1)*(NUK(ISS,K2)-1)
  234.                DO 212 K = 1,IDIM
  235.                   A2(K,ISS) = XCOOR(IREF+K)
  236.  212           CONTINUE
  237.  211        CONTINUE
  238.  
  239. CNNN-------SEQUENCE POUR LA FACE K2 DU MAILLAGE--------------
  240.  
  241.             CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU)
  242.  
  243.            IF (KVU.NE.0) THEN
  244.  
  245.              C = U2(IDIM+1)
  246.              DO 401  IES = 1,IDIM
  247.              C = C + U2(IES)*O1(IES)
  248.  401         CONTINUE
  249.              IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU
  250.  
  251.              IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1))  THEN
  252.               CALL KREMP2(K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO)
  253.              ENDIF
  254.            ENDIF
  255. CNNN-------------------------------------------------------------
  256.  
  257.       IF(IAXE.NE.0) THEN
  258.  
  259. CNNN-------SEQUENCE POUR LA FACE SYMETRIQUE DE K2--------------------
  260. C    L'AXE DE SYMETRIE EST DEFINI PAR UN POINT UA
  261. C                                     UNE NORMALE UNITAIRE
  262. C    CALCUL DES SYMETRIQUES DE U2(NORMALE)  ET A2(SOMMETS)
  263. C
  264.             KES1 = IDIM + 1
  265.             CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN)
  266.  
  267.             CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU)
  268.  
  269.            IF (KVU.NE.0) THEN
  270.  
  271.              C = UU2(IDIM+1)
  272.              DO 403  IES = 1,IDIM
  273.              C = C + UU2(IES)*O1(IES)
  274.  403         CONTINUE
  275.              IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU
  276.  
  277.              IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1))  THEN
  278.               CALL KREMP2(K1,K2,O1,AA2,C,UU2,SHC2D,SKBUF2,SKRESO)
  279.              ENDIF
  280.            ENDIF
  281. CNNN-------------------------------------------------------------
  282.       ENDIF
  283.  
  284.  400      CONTINUE
  285. C
  286. C>>> RECOMBINAISON
  287. C
  288.       SSP1 = SP(KS1)
  289. C<<
  290.       IF(EXTINC.LE.1D-3) THEN
  291.         CALL KRCOM2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO)
  292.       ELSE
  293.         CALL KRCOA2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO,EXTINC)
  294.       ENDIF
  295. C<<
  296.         DO 920 K2 = 1,MFACE
  297.         PLIG.FACT(K2) = PLIG.FACT(K2) + FF1(K2)
  298.  920    CONTINUE
  299.  
  300.  310    CONTINUE
  301.         SEGDES IPATCH
  302.         SEGDES PLIG
  303.  
  304.  300  CONTINUE
  305.  
  306. C     -------------------------------------------------------------
  307.  
  308.       DO 500 K2=1,MFACE
  309.       IPATCH=KPATCH(K2)
  310.       SEGSUP IPATCH
  311. 500   CONTINUE
  312.       SEGSUP SKFAC2
  313.  
  314.       SEGSUP SHC2D,SKBUF2
  315. C
  316. C>>>  CALCUL DES BILANS, IMPRESSION, NORMALISATION
  317. C     --------------------------------------------
  318.  
  319.        LIMP=KIMP
  320. C<<
  321.       IF(EXTINC.GT.1D-3) THEN
  322.        INOR = 0
  323.       ENDIF
  324. C<<
  325.        CALL KFN(IFACFO,INOR,LIMP)
  326. C
  327. *//////
  328.       IF(KIMP.GE.3) THEN
  329.       CALL PRFACF(IFACFO)
  330.       ENDIF
  331. *//////
  332.       LTITR=1
  333.       CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  334.  
  335. C     Destruction de IFACFO après traduction
  336.       SEGACT IFACFO
  337.       NNBEL1 = LFACT(/1)
  338.       DO 950 NN = 1,NNBEL1
  339.          PLIG = LFACT(NN)
  340.          SEGSUP PLIG
  341.  950  CONTINUE
  342.       SEGSUP IFACFO
  343.  
  344.       SEGSUP STRAV, SKRESO
  345.  
  346.       RETURN
  347.       END
  348.  
  349.  
  350.  

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