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    CB215821  16/04/21    21:16:45     8920
  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 sym‚trie
  15. *     INOR   : paramŠtre 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. C
  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.           SEGACT IAXE
  129.           IF(IIMPI.GE.1) THEN
  130.                WRITE(6,*) ' CALCUL AVEC AXE DE SYMETRIE '
  131.           ENDIF
  132. C         Numéro des 2 points définissant l'axe
  133.           IREF1 = (IDIM+1)*(IAXE.LECT(1)-1)
  134.           IREF2 = (IDIM+1)*(IAXE.LECT(2)-1)
  135. C         On garde un point ( UA ) et la normale ( UN )
  136.           UA(1) = XCOOR(IREF1+1)
  137.           UA(2) = XCOOR(IREF1+2)
  138.           UN(1) = UA(2) - XCOOR(IREF2+2)
  139.           UN(2) = XCOOR(IREF2+1) - UA(1)
  140.           DUN=SQRT(UN(1)*UN(1)+UN(2)*UN(2))
  141.           IF (DUN.LT.1.E-5) THEN
  142.               WRITE(6,*) ' LES POINTS DE L AXE SONT CONFONDUS '
  143.               CALL ARRET(0)
  144.               RETURN
  145.           ENDIF
  146.           UN(1) = UN(1)/DUN
  147.           UN(2) = UN(2)/DUN
  148.           SEGDES IAXE
  149.        ENDIF
  150. CNN------------------------------------------------------------------
  151.       NSOM = 2
  152.       EPS = 1E-5
  153.  
  154. C
  155. C>>>  PREPARATION
  156. C
  157.       CALL KALPR2(MYMOD,INFOEL,SKFAC2,SHC2D,XDEC,NELD,SKRESO)
  158. C
  159. C>>>  INITIALISATION OBJET FACFOR
  160. C
  161.       NBEL1 = NELD
  162.       NNBEL1 = NELD+1
  163.       NBEL2 = NELD
  164.       SEGINI IFACFO
  165.  
  166.       DO 900 LS=1,NNBEL1
  167.       SEGINI PLIG
  168.       LFACT(LS) = PLIG
  169.       SEGDES PLIG
  170.  900  CONTINUE
  171.  
  172.       PSUR = LFACT(NNBEL1)
  173.       SEGACT PSUR*MOD
  174.       SEGACT SKFAC2
  175.       MFACE = NUK(/2)
  176.       DO 910 K1 = 1,MFACE
  177.         PSUR.FACT(K1) = PSUR.FACT(K1) + S(K1)
  178.  910  CONTINUE
  179.  
  180. C     -------------------------------------------------------------
  181. C>>>  CALCUL
  182. C
  183.       SEGACT SHC2D,SKFAC2*MOD
  184.       MFACE = NUK(/2)
  185.  
  186.  
  187.       NR = IR(/1)
  188.       NFC = KRO(/1)
  189.       NOC = 4
  190.       SEGINI SKBUF2
  191.  
  192.       CALL KFALIM(MFACE,K1D,K1F)
  193.       DO 300  K1 = K1D,K1F
  194.  
  195.         PLIG = LFACT(K1)
  196.         SEGACT PLIG*MOD
  197.  
  198.         DO 312 K=1,IDIM+1
  199.            U1(K) = U(K,K1)
  200.  312    CONTINUE
  201.  
  202.          DO 201 ISS = 1,NSOM
  203.             IREF = (IDIM+1)*(NUK(ISS,K1)-1)
  204.             DO 202 K = 1,IDIM
  205.             A1(K,ISS) = XCOOR(IREF+K)
  206.  202        CONTINUE
  207.  201     CONTINUE
  208.  
  209.         CALL KINPR2(U1,SHC2D,SKBUF2,SKRESO)
  210.         CALL KVERI2(SHC2D,SKBUF2,SKRESO)
  211.  
  212.         IPATCH = KPATCH(K1)
  213.         SEGACT IPATCH
  214.         NPATCH = GP(/2)
  215.  
  216.           CALL KTYPKS(NPATCH,KS1D,KS1F)
  217.  
  218.           DO 310 KS1 = KS1D,KS1F
  219.  
  220.             DO 311 K=1,IDIM
  221.             O1(K) = GP(K,KS1)
  222.  311        CONTINUE
  223.             IF (IIMPI.GE.4) THEN
  224.                 WRITE(6,*) K1,KS1,' O1 ',(O1(I1),I1=1,IDIM)
  225.             ENDIF
  226.             CALL KINBU2(SKBUF2,SKRESO)
  227. C
  228. C    FACES
  229. C    -----
  230.           DO 400 K2 = 1,MFACE
  231.  
  232.             DO 412 K=1,IDIM+1
  233.             U2(K) = U(K,K2)
  234.  412        CONTINUE
  235.  
  236.             DO 211 ISS = 1,NSOM
  237.                IREF = (IDIM+1)*(NUK(ISS,K2)-1)
  238.                DO 212 K = 1,IDIM
  239.                   A2(K,ISS) = XCOOR(IREF+K)
  240.  212           CONTINUE
  241.  211        CONTINUE
  242.  
  243. CNNN-------SEQUENCE POUR LA FACE K2 DU MAILLAGE--------------
  244.  
  245.             CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU)
  246.  
  247.            IF (KVU.NE.0) THEN
  248.  
  249.              C = U2(IDIM+1)
  250.              DO 401  IES = 1,IDIM
  251.              C = C + U2(IES)*O1(IES)
  252.  401         CONTINUE
  253.              IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU
  254.  
  255.              IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1))  THEN
  256.               CALL KREMP2(K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO)
  257.              ENDIF
  258.            ENDIF
  259. CNNN-------------------------------------------------------------
  260.  
  261.       IF(IAXE.NE.0) THEN
  262.  
  263. CNNN-------SEQUENCE POUR LA FACE SYMETRIQUE DE K2--------------------
  264. C    L'AXE DE SYMETRIE EST DEFINI PAR UN POINT UA
  265. C                                     UNE NORMALE UNITAIRE
  266. C    CALCUL DES SYMETRIQUES DE U2(NORMALE)  ET A2(SOMMETS)
  267. C
  268.             KES1 = IDIM + 1
  269.             CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN)
  270.  
  271.             CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU)
  272.  
  273.            IF (KVU.NE.0) THEN
  274.  
  275.              C = UU2(IDIM+1)
  276.              DO 403  IES = 1,IDIM
  277.              C = C + UU2(IES)*O1(IES)
  278.  403         CONTINUE
  279.              IF (IIMPI.GE.4) WRITE(6,*) 'FACES ',K1,' ',K2,' KVU ',KVU
  280.  
  281.              IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1))  THEN
  282.               CALL KREMP2(K1,K2,O1,AA2,C,UU2,SHC2D,SKBUF2,SKRESO)
  283.              ENDIF
  284.            ENDIF
  285. CNNN-------------------------------------------------------------
  286.       ENDIF
  287.  
  288.  400      CONTINUE
  289. C
  290. C>>> RECOMBINAISON
  291. C
  292.       SSP1 = SP(KS1)
  293.  
  294. C<<
  295.       IF(EXTINC.LE.1D-3) THEN
  296.         CALL KRCOM2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO)
  297.       ELSE
  298.         CALL KRCOA2(K1,SSP1,SHC2D,SKFAC2,SKBUF2,SKRESO,EXTINC)
  299.       ENDIF
  300. C<<
  301.         DO 920 K2 = 1,MFACE
  302.         PLIG.FACT(K2) = PLIG.FACT(K2) + FF1(K2)
  303.  920    CONTINUE
  304.  
  305.  310    CONTINUE
  306.         SEGDES IPATCH
  307.         SEGDES PLIG
  308.  
  309.  300  CONTINUE
  310.  
  311. C     -------------------------------------------------------------
  312.  
  313.       DO 500 K2=1,MFACE
  314.       IPATCH=KPATCH(K2)
  315.       SEGSUP IPATCH
  316. 500   CONTINUE
  317.       SEGSUP SKFAC2
  318.  
  319.       SEGSUP SHC2D,SKBUF2
  320. C
  321. C>>>  CALCUL DES BILANS, IMPRESSION, NORMALISATION
  322. C     --------------------------------------------
  323.  
  324.        LIMP=KIMP
  325. C<<
  326.       IF(EXTINC.GT.1D-3) THEN
  327.        INOR = 0
  328.       ENDIF
  329. C<<
  330.        CALL KFN(IFACFO,INOR,LIMP)
  331. C
  332. *//////
  333.       IF(KIMP.GE.3) THEN
  334.       CALL PRFACF(IFACFO)
  335.       ENDIF
  336. *//////
  337.       LTITR=1
  338.       CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR)
  339.  
  340. C     Destruction de IFACFO après traduction
  341.       SEGACT IFACFO
  342.       NNBEL1 = LFACT(/1)
  343.       DO 950 NN = 1,NNBEL1
  344.          PLIG = LFACT(NN)
  345.          SEGSUP PLIG
  346.  950  CONTINUE
  347.       SEGSUP IFACFO
  348.  
  349.       SEGSUP STRAV, SKRESO
  350.  
  351.       RETURN
  352.       END
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  

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