Télécharger la plaquette Cast3M


fr en

Télécharger zechi2.eso

Retour à la liste

Numérotation des lignes : 

zechi2

  1. C ZECHI2    SOURCE    FANDEUR   22/01/03    21:16:02     11136          
  2.       SUBROUTINE ZECHI2(IKAS,IVOL1,MTAB1,MTAB2,MTAB3,MPOVA1,MPOVA2,
  3.      &                 IKH,IKT,IKP,MELEVF,MLENT1,NOMP,NOMD)
  4. C-----------------------------------------------------------------------
  5. C coeff d'échange étant un SCAL ou CHPO CENTRE, le champ exterieur
  6. C un SCAL, un CHPO CENTRE ou un CHPO SOMMET.
  7. C-----------------------------------------------------------------------
  8. C
  9. C--------------------
  10. C Paramètres Entrée :
  11. C--------------------
  12. C
  13. C E/  IKAS    : Type de situation à traiter (1=EF, 2 ou 3=VF)
  14. C E/  IVOL1   : Type d'échange (0=surfacique, 1=volumique)
  15. C E/  MTAB1   : Pointeur de la table EQEX
  16. C E/  MTAB2   : Pointeur de la table DOMAINE locale
  17. C E/  MTAB3   : Pointeur de la table KIZX
  18. C E/  MPOVA1  : MPOVAL des valeurs du coefficient d'échange
  19. C E/  MPOVA2  : MPOVAL des valeurs du champ exterieur
  20. C E/  IKH     : Forme originel du coefficient d'échange
  21. C               (0=CHPO CENTRE, 1=FLOTTANT)
  22. C E/  IKT     : Forme originel du champ exterieur
  23. C               (0=CHPO CENTRE, 1=FLOTTANT, 4=CHPO SOMMET)
  24. C E/  IKP     : Support de l'inconnue primale
  25. C               (0=CHPO CENTRE, 4=CHPO SOMMET)
  26. C E/  MELEVF  : Pointeur vers les points CENTRE du maillage volumique
  27. C               en correspondance avec les points CENTRE surfacique
  28. C               (Utilisé en Formulation VF et échange surfacique)
  29. C E/  MLENT1  : Correspondance de numérotations pour le champ exterieur
  30. C               MLENT1.LECT(I)=J : point I en Jième position du spg
  31. C               (Utilisé lorsque le champ exterieur est au SOMMET)
  32. C E/  NOMP    : Nom de l'inconnue primale
  33. C E/  NOMD    : Nom de l'inconnue duale
  34. C
  35. C------------------
  36. C Champs calculés :
  37. C------------------
  38. C
  39. C   MTAB3.'MATELM' : Matrice associé à l'opérateur ECHIMP
  40. C   MTAB1.'SMBR'   : Second membre du système matriciel issu de la
  41. C                    discrétisation, la contribution de ECHIMP y est
  42. C                    assemblée.
  43. C
  44. C-----------------------------------------------------------------------
  45.       IMPLICIT INTEGER(I-N)
  46.       IMPLICIT REAL*8 (A-H,O-Z)
  47. C
  48. -INC CCGEOME
  49. -INC PPARAM
  50. -INC CCOPTIO
  51. -INC SIZFFB
  52. -INC SMCHPOI
  53. -INC SMCHAML
  54. -INC SMCOORD
  55. -INC SMELEME
  56. -INC SMLENTI
  58. C
  59.       CHARACTER*8 TYPE,TYPC,TYPS
  60.       CHARACTER*(*) NOMP,NOMD
  61.       CHARACTER*(LOCOMP) NOM0
  62.       INTEGER SPGP,SPGD
  63. C
  64. C- Initialisations
  65. C
  66.       MLENT2 = 0
  67.       MCHPO1 = 0
  68.       MCHELM = 0
  69.       NBCOMP = 1
  70.       IAXI   = 0
  71.       IF (IFOMOD.EQ.0) IAXI=2
  72.       SEGACT MPOVA1
  73.       SEGACT MPOVA2
  74. C
  75. C- Récupération des informations géométriques locales
  76. C
  77.       CALL LEKTAB(MTAB2,'CENTRE   ',MELEMC)
  78.       CALL LEKTAB(MTAB2,'SOMMET   ',MELEMS)
  79.       CALL LEKTAB(MTAB2,'MAILLAGE ',MELEME)
  80.       CALL KRIPAD(MELEMS,MLENTI)
  81. C
  82. C- En echange surfacique et option VF création du spg du second-membre
  83. C- différent de MELEVF à cause des coins (dans le spg chaque point
  84. C- n'est présent qu'une fois meme si il est connecté plusieurs fois)
  85. C
  86.       IF (IKAS.NE.1 .AND. IVOL1.EQ.0) THEN
  87.          IPT1  = MELEVF
  88.          SEGACT  IPT1
  89.          SEGINI, IPT2=IPT1
  90.          IOK1  = 1
  91.          NUMPD = IPT2.NUM(/2)
  92.          DO 10 I=2,NUMPD
  93.             ITEST = IPT1.NUM(1,I)
  94.             DO 5 J=1,IOK1
  95.                JTEST = IPT2.NUM(1,J)
  96.                IF (JTEST.EQ.ITEST) GOTO 10
  97.   5         CONTINUE
  98.             IOK1 = IOK1 + 1
  99.             IPT2.NUM(1,IOK1) = ITEST
  100.  10      CONTINUE
  101.          IF (IOK1.NE.NUMPD) THEN
  102.             NBSOUS = 0
  103.             NBELEM = IOK1
  104.             NBREF  = 0
  105.             NBNN   = 1
  106.             SEGADJ IPT2
  107.          ENDIF
  108.          SEGDES IPT2
  109.       ENDIF
  110. C
  111. C- Maillage de connectivités et supports géométriques des inconnues
  112. C
  113. C   SPGP  : Support géométrique local de l'inconnue primale
  114. C   SPGD  : Idem pour la duale
  115. C   MLOCP : Connectivité local pour l'inconnue primale
  116. C   MLOCD : Idem pour la duale
  117. C
  118.       IF (IKAS.EQ.1) THEN
  119.          TYPS = 'SOMMET  '
  120.          SPGD  = MELEMS
  121.          IF (IKP.EQ.0) THEN
  122.             SPGP  = MELEMC
  123.             MLOCD = MELEME
  124.             MLOCP = MELEMC
  125.          ELSE
  126.             SPGP  = MELEMS
  127.             MLOCD = MELEME
  128.             MLOCP = MELEME
  129.          ENDIF
  130.       ELSE
  131.          TYPS = 'CENTRE  '
  132.          IF (IVOL1.EQ.0) THEN
  133.             SPGD  = IPT2
  134.             MLOCD = MELEVF
  135.          ELSE
  136.             SPGD  = MELEMC
  137.             MLOCD = MELEMC
  138.          ENDIF
  139.          IF (IKP.EQ.0) THEN
  140.             SPGP  = MELEMC
  141.             MLOCP = MELEMC
  142.          ELSE
  143.             SPGP  = MELEMS
  144.             MLOCP = MELEME
  145.          ENDIF
  146.          CALL KRIPAD(SPGD,MLENT2)
  147.       ENDIF
  148. C
  149. C- Création du CHPO contenant la contribution au second membre de ECHIMP
  150. C
  151.       NAT      = 1
  152.       NSOUPO   = 1
  153.       SEGINI MCHPOI
  154.       MTYPOI   = TYPS
  155.       JATTRI(1) = 2
  156.       IFOPOI   = IFOUR
  157.       NC       = 1
  158.       SEGINI MSOUPO
  159.       IPCHP(1) = MSOUPO
  160.       SEGDES MCHPOI
  161.       NOCOMP(1)= NOMD
  162.       IGEOC    = SPGD
  163.       IPT3     = SPGD
  164.       SEGACT IPT3
  165.       N        = IPT3.NUM(/2)
  166.       SEGDES IPT3
  167.       SEGINI MPOVAL
  168.       IPOVAL   = MPOVAL
  169.       SEGDES MSOUPO
  170. C
  171. C-------------------
  172. C-------------------
  173. C
  174.       IF (IKAS.EQ.1) THEN
  175. C
  176. C- Matrice EF dans le cas ou l'inconnue primale est au CENTRE
  177. C- (matrice colonne : h fois diagonale de la matrice MASSE condensée)
  178. C
  179.          IF (IKP.EQ.0) THEN
  180.             CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  181.             IF (IERR.NE.0) RETURN
  182.             SEGACT MCHELM
  183.             NRIGE  = 7
  184.             NKID   = 9
  185.             NKMT   = 7
  186.             NMATRI = 1
  187.             SEGINI MATRIK
  188.             IRIGEL(1,1) = MLOCP
  189.             IRIGEL(2,1) = MLOCD
  190.             IRIGEL(7,1) = 3
  191.             NBME   = 1
  192.             SEGACT MELEME
  193.             NBSOUS = LISOUS(/1)
  194.             IF (NBSOUS.EQ.0) NBSOUS=1
  195.             SEGINI IMATRI
  196.             IRIGEL(4,1) = IMATRI
  197.             SEGDES MATRIK
  198.             KSPGP = SPGP
  199.             KSPGD = SPGD
  200.             LISPRI(1) = NOMP
  201.             LISDUA(1) = NOMD
  202.             NUTOEL = 0
  203.             DO 30 L=1,NBSOUS
  204.                IPT1 = MELEME
  205.                IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  206.                SEGACT IPT1
  207.                NP     = 1
  208.                MP     = IPT1.NUM(/1)
  209.                NBEL   = IPT1.NUM(/2)
  210.                SEGINI IZAFM
  211.                LIZAFM(L,1) = IZAFM
  212.                MCHAML = ICHAML(L)
  213.                SEGACT MCHAML
  214.                MELVAL = IELVAL(1)
  215.                SEGACT MELVAL
  216.                DO 20 K=1,NBEL
  217.                   NK   = NUTOEL + K
  218.                   KPOS = 1 + (1-IKH)*(NK-1)
  219.                   DO 15 I=1,MP
  220.                      VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  221.                      AM(K,1,I) = AM(K,1,I) + VAL1
  222. C                    write(6,*) 'EF CENTRE AM K I',K,I,AM(K,1,I)
  223.  15               CONTINUE
  224.  20            CONTINUE
  225.                SEGDES IZAFM
  226.                SEGDES IPT1
  227.                SEGDES MCHAML,MELVAL
  228.                NUTOEL = NUTOEL + NBEL
  229.  30         CONTINUE
  230.             IF (NBSOUS.NE.1) SEGDES MELEME
  231.             SEGDES MCHELM
  232.             SEGDES IMATRI
  233. C
  234. C- Matrice EF dans le cas ou l'inconnue primale est au SOMMET
  235. C- (matrice carrée : h fois matrice MASSE consistante)
  236. C
  237.          ELSE
  238.             NRIGE  = 7
  239.             NKID   = 9
  240.             NKMT   = 7
  241.             NMATRI = 1
  242.             SEGINI MATRIK
  243.             IRIGEL(1,1) = MLOCP
  244.             IRIGEL(2,1) = MLOCD
  245.             IRIGEL(7,1) = 2
  246.             NBME   = 1
  247.             SEGACT MELEME
  248.             NBSOUS = LISOUS(/1)
  249.             IF (NBSOUS.EQ.0) NBSOUS=1
  250.             SEGINI IMATRI
  251.             IRIGEL(4,1) = IMATRI
  252.             SEGDES MATRIK
  253.             KSPGP = SPGP
  254.             KSPGD = SPGD
  255.             LISPRI(1) = NOMP
  256.             LISDUA(1) = NOMD
  257.             NUTOEL = 0
  258.             DO 100 L=1,NBSOUS
  259.                IPT1 = MELEME
  260.                IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  261.                SEGACT IPT1
  262.                NP     = IPT1.NUM(/1)
  263.                NBEL   = IPT1.NUM(/2)
  264.                MP     = NP
  265.                SEGINI IZAFM
  266.                LIZAFM(L,1) = IZAFM
  267.                NOM0   = NOMS(IPT1.ITYPEL)
  268.                CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  269.                IF (IZFFM.EQ.0) THEN
  270. C Echec lors de la lecture des fonctions de forme d'un élément.
  271.                   CALL ERREUR(662)
  272.                   RETURN
  273.                ENDIF
  274.                SEGACT IZFFM*MOD
  275.                IZHR = KZHR(1)
  276.                SEGACT IZHR*MOD
  277.                NPG = GR(/3)
  278.                NES = GR(/1)
  279.                DO 90 K=1,NBEL
  280.                   NK   = NUTOEL + K
  281.                   KPOS = 1 + (1-IKH)*(NK-1)
  282.                   DO 50 I=1,NP
  283.                      II     = IPT1.NUM(I,K)
  284.                      DO 40 N=1,IDIM
  285.                         XYZ(N,I) = XCOOR((II-1)*(IDIM+1)+N)
  286.  40                  CONTINUE
  287.  50               CONTINUE
  288.                   CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,
  289.      &                        NPG,IAXI,AIRE)
  290.                   DO 80 I=1,NP
  291.                      DO 70 J=1,NP
  292.                         UU = 0.D0
  293.                         DO 60 LG=1,NPG
  294.                            UU = UU + FN(I,LG)*FN(J,LG)*PGSQ(LG)
  295.  60                     CONTINUE
  296.                         AM(K,I,J) = MPOVA1.VPOCHA(KPOS,1) * UU
  297. C                       write(6,*) 'EF SOMMET AM K I J',K,I,J,AM(K,I,J)
  298.  70                  CONTINUE
  299.  80               CONTINUE
  300.  90            CONTINUE
  301.                SEGDES IPT1
  302.                SEGDES IZAFM
  303.                SEGDES IZFFM*MOD
  304.                SEGDES IZHR
  305.                NUTOEL = NUTOEL + NBEL
  306. 100         CONTINUE
  307.             IF (NBSOUS.NE.1) SEGDES MELEME
  308.             SEGDES IMATRI
  309.          ENDIF
  310. C
  311. C- Second membre EF, champ exterieur FLOTTANT ou CHPO CENTRE
  312. C- (matrice MASSE condensée saturé par h*champ exterieur)
  313. C
  314.          IF (IKT.EQ.0.OR.IKT.EQ.1) THEN
  315.             IF (MCHELM.EQ.0) CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  316.             IF (IERR.NE.0) RETURN
  317.             SEGACT MCHELM
  318.             SEGACT MELEME
  319.             NBSOUS = LISOUS(/1)
  320.             IF (NBSOUS.EQ.0) NBSOUS=1
  321.             NUTOEL = 0
  322.             DO 130 L=1,NBSOUS
  323.                IPT1 = MELEME
  324.                IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  325.                SEGACT IPT1
  326.                NP     = IPT1.NUM(/1)
  327.                NBEL   = IPT1.NUM(/2)
  328.                MCHAML = ICHAML(L)
  329.                SEGACT MCHAML
  330.                MELVAL = IELVAL(1)
  331.                SEGACT MELVAL
  332.                DO 120 K=1,NBEL
  333.                   NK   = NUTOEL + K
  334.                   KPOS = 1 + (1-IKH)*(NK-1)
  335.                   KTEX = 1 + (1-IKT)*(NK-1)
  336.                   DO 110 I=1,NP
  337.                      II   = IPT1.NUM(I,K)
  338.                      IPOS = LECT(II)
  339.                      VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  340.      &                    * MPOVA2.VPOCHA(KTEX,1)
  341.                      VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  342. C                 write(6,*) 'EF CENTRE VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  343. 110               CONTINUE
  344. 120            CONTINUE
  345.                SEGDES IPT1
  346.                SEGDES MCHAML,MELVAL
  347.                NUTOEL = NUTOEL + NBEL
  348. 130         CONTINUE
  349.             IF (NBSOUS.NE.1) SEGDES MELEME
  350.             SEGDES MCHELM
  351. C
  352. C- Second membre EF, champ exterieur CHPO SOMMET
  353. C- (matrice MASSE consistante saturée par h*champ exterieur)
  354. C
  355.          ELSE
  356.             SEGACT MELEME
  357.             NBSOUS = LISOUS(/1)
  358.             IF (NBSOUS.EQ.0) NBSOUS=1
  359.             NUTOEL = 0
  360.             DO 200 L=1,NBSOUS
  361.                IPT1 = MELEME
  362.                IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  363.                SEGACT IPT1
  364.                NP   = IPT1.NUM(/1)
  365.                NBEL = IPT1.NUM(/2)
  366.                NOM0 = NOMS(IPT1.ITYPEL)
  367.                CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  368.                IF (IZFFM.EQ.0) THEN
  369. C Echec lors de la lecture des fonctions de forme d'un élément.
  370.                   CALL ERREUR(662)
  371.                   RETURN
  372.                ENDIF
  373.                SEGACT IZFFM*MOD
  374.                IZHR = KZHR(1)
  375.                SEGACT IZHR*MOD
  376.                NPG = GR(/3)
  377.                NES = GR(/1)
  378.                DO 190 K=1,NBEL
  379.                   NK   = NUTOEL + K
  380.                   KPOS = 1 + (1-IKH)*(NK-1)
  381.                   DO 150 I=1,NP
  382.                      II     = IPT1.NUM(I,K)
  383.                      DO 140 N=1,IDIM
  384.                         XYZ(N,I) = XCOOR((II-1)*(IDIM+1)+N)
  385. 140                  CONTINUE
  386. 150               CONTINUE
  387.                   CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,
  388.      &                        NPG,IAXI,AIRE)
  389.                   DO 180 I=1,NP
  390.                      II   = IPT1.NUM(I,K)
  391.                      IPOS = LECT(II)
  392.                      SOM1 = 0.D0
  393.                      DO 170 J=1,NP
  394.                         JPOS = MLENT1.LECT(IPT1.NUM(J,K))
  395.                         UU = 0.D0
  396.                         DO 160 LG=1,NPG
  397.                            UU = UU + FN(I,LG)*FN(J,LG)*PGSQ(LG)
  398. 160                     CONTINUE
  399.                         SOM1 = SOM1 + MPOVA1.VPOCHA(KPOS,1)
  400.      &                              * MPOVA2.VPOCHA(JPOS,1) * UU
  401. 170                  CONTINUE
  402.                      VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + SOM1
  403. C                 write(6,*) 'EF SOMMET VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  404. 180               CONTINUE
  405. 190            CONTINUE
  406.                SEGDES IPT1
  407.                SEGDES IZFFM*MOD
  408.                SEGDES IZHR
  409.                NUTOEL = NUTOEL + NBEL
  410. 200         CONTINUE
  411.             IF (NBSOUS.NE.1) SEGDES MELEME
  412.          ENDIF
  413. C
  414. C-------------------
  415. C-------------------
  416. C
  417.       ELSE
  418. C
  419. C- Matrice VF dans le cas ou l'inconnue primale est au CENTRE
  420. C- (matrice IDENTITE multipliée par h*VOLUME)
  421. C
  422.          IF (IKP.EQ.0) THEN
  423.             CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPO3)
  424.             IF (IERR.NE.0) RETURN
  425.             CALL LICHT(MCHPO3,MPOVA3,TYPC,IGEOM)
  426.             NRIGE  = 7
  427.             NKID   = 9
  428.             NKMT   = 7
  429.             NMATRI = 1
  430.             SEGINI MATRIK
  431.             IRIGEL(1,1) = MLOCP
  432.             IRIGEL(2,1) = MLOCD
  433.             IF (MLOCP.EQ.MLOCD) THEN
  434.                IF (NOMP.EQ.NOMD) THEN
  435.                   IRIGEL(7,1) = 5
  436.                ELSE
  437.                   IRIGEL(7,1) = 2
  438.                ENDIF
  439.             ELSE
  440.                IRIGEL(7,1) = 3
  441.             ENDIF
  442.             NBME   = 1
  443.             NBSOUS = 1
  444.             SEGINI IMATRI
  445.             IRIGEL(4,1) = IMATRI
  446.             SEGDES MATRIK
  447.             KSPGP = SPGP
  448.             KSPGD = SPGD
  449.             LISPRI(1) = NOMP
  450.             LISDUA(1) = NOMD
  451.             NBEL = MPOVA3.VPOCHA(/1)
  452.             NP   = 1
  453.             MP   = 1
  454.             SEGINI IZAFM
  455.             LIZAFM(1,1) = IZAFM
  456.             SEGDES IMATRI
  457.             DO 210 NK=1,NBEL
  458.                KPOS = 1 + (1-IKH)*(NK-1)
  459.                AM(NK,1,1) = AM(NK,1,1) +
  460.      &                      MPOVA1.VPOCHA(KPOS,1) * MPOVA3.VPOCHA(NK,1)
  461. C              write(6,*) 'VF CENTRE AM NK',NK,AM(NK,1,1)
  462. 210         CONTINUE
  463. C
  464. C- Matrice VF dans le cas ou l'inconnue primale est au SOMMET
  465. C- (matrice ligne : h fois diagonale matrice MASSE condensée)
  466. C
  467.          ELSE
  468.             CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  469.             IF (IERR.NE.0) RETURN
  470.             SEGACT MCHELM
  471.             NRIGE  = 7
  472.             NKID   = 9
  473.             NKMT   = 7
  474.             NMATRI = 1
  475.             SEGINI MATRIK
  476.             IRIGEL(1,1) = MLOCP
  477.             IRIGEL(2,1) = MLOCD
  478.             IRIGEL(7,1) = 3
  479.             NBME   = 1
  480.             SEGACT MELEME
  481.             NBSOUS = LISOUS(/1)
  482.             IF (NBSOUS.EQ.0) NBSOUS=1
  483.             SEGINI IMATRI
  484.             IRIGEL(4,1) = IMATRI
  485.             SEGDES MATRIK
  486.             KSPGP = SPGP
  487.             KSPGD = SPGD
  488.             LISPRI(1) = NOMP
  489.             LISDUA(1) = NOMD
  490.             NUTOEL = 0
  491.             DO 240 L=1,NBSOUS
  492.                IPT1 = MELEME
  493.                IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  494.                SEGACT IPT1
  495.                NP     = IPT1.NUM(/1)
  496.                MP     = 1
  497.                NBEL   = IPT1.NUM(/2)
  498.                SEGINI IZAFM
  499.                LIZAFM(L,1) = IZAFM
  500.                MCHAML = ICHAML(L)
  501.                SEGACT MCHAML
  502.                MELVAL = IELVAL(1)
  503.                SEGACT MELVAL
  504.                DO 230 K=1,NBEL
  505.                   NK   = NUTOEL + K
  506.                   KPOS = 1 + (1-IKH)*(NK-1)
  507.                   DO 220 I=1,NP
  508.                      VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  509.                      AM(K,I,1) = AM(K,I,1) + VAL1
  510. C                    write(6,*) 'VF SOMMET AM K I',K,I,AM(K,I,1)
  511. 220               CONTINUE
  512. 230            CONTINUE
  513.                SEGDES IPT1
  514.                SEGDES MCHAML,MELVAL
  515.                SEGDES IZAFM
  516.                NUTOEL = NUTOEL + NBEL
  517. 240         CONTINUE
  518.             IF (NBSOUS.NE.1) SEGDES MELEME
  519.             SEGDES MCHELM
  520.             SEGDES IMATRI
  521.          ENDIF
  522. C
  523. C- Second membre VF dans le cas ou le champ exterieur est au CENTRE
  524. C- (matrice diagonale h*VOLUME saturée par le champ exterieur)
  525. C
  526.          IF (IKT.EQ.0.OR.IKT.EQ.1) THEN
  527.             IF (MCHPO1.EQ.0) CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPO1)
  528.             IF (IERR.NE.0) RETURN
  529.             CALL LICHT(MCHPO1,MPOVA3,TYPC,IGEOM)
  530.             NBEL = MPOVA3.VPOCHA(/1)
  531.             IPT2   = MLOCD
  532.             SEGACT IPT2
  533.             DO 250 NK=1,NBEL
  534.                IPOS = MLENT2.LECT(IPT2.NUM(1,NK))
  535.                KPOS = 1 + (1-IKH)*(NK-1)
  536.                KTEX = 1 + (1-IKT)*(NK-1)
  537.                VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA2.VPOCHA(KTEX,1)
  538.      &              * MPOVA3.VPOCHA(NK,1)
  539.                VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  540. C              write(6,*) 'VF CENTRE VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  541. 250         CONTINUE
  542.             SEGDES IPT2
  543.             SEGDES MPOVA3
  544. C
  545. C- Second membre VF dans le cas ou l'inconnue primale est au SOMMET
  546. C- (matrice MASSE condensée saturée par h*champ exterieur)
  547. C
  548.          ELSE
  549.             IF (MCHELM.EQ.0) CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  550.             IF (IERR.NE.0) RETURN
  551.             SEGACT MCHELM
  552.             SEGACT MELEME
  553.             NBSOUS = LISOUS(/1)
  554.             IF (NBSOUS.EQ.0) NBSOUS=1
  555.             NUTOEL = 0
  556.             IPT2   = MLOCD
  557.             SEGACT IPT2
  558.             DO 280 L=1,NBSOUS
  559.                IPT1 = MELEME
  560.                IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  561.                SEGACT IPT1
  562.                NP     = IPT1.NUM(/1)
  563.                NBEL   = IPT1.NUM(/2)
  564.                MCHAML = ICHAML(L)
  565.                SEGACT MCHAML
  566.                MELVAL = IELVAL(1)
  567.                SEGACT MELVAL
  568.                DO 270 K=1,NBEL
  569.                   NK   = NUTOEL + K
  570.                   IPOS = MLENT2.LECT(IPT2.NUM(1,NK))
  571.                   KPOS = 1 + (1-IKH)*(NK-1)
  572.                   SOM1 = 0.D0
  573.                   DO 260 J=1,NP
  574.                      JPOS = MLENT1.LECT(IPT1.NUM(J,K))
  575.                      SOM1 = SOM1 + MPOVA2.VPOCHA(JPOS,1)*VELCHE(J,K)
  576. 260               CONTINUE
  577.                   VAL1 = SOM1 * MPOVA1.VPOCHA(KPOS,1)
  578.                   VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  579. C              write(6,*) 'VF SOMMET VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  580. 270            CONTINUE
  581.                SEGDES IPT1
  582.                SEGDES MCHAML,MELVAL
  583.                NUTOEL = NUTOEL + NBEL
  584. 280         CONTINUE
  585.             IF (NBSOUS.NE.1) SEGDES MELEME
  586.             SEGDES MCHELM
  587.             SEGDES IPT2
  588.          ENDIF
  589.       ENDIF
  590. C
  591. C- Désactivation
  592. C
  593.       SEGDES MPOVA2
  594.       SEGDES MPOVA1
  595.       SEGDES MPOVAL
  596.       SEGSUP MLENTI
  597.       IF (MLENT2.NE.0) SEGSUP MLENT2
  598. C
  599. C- Ecriture de la matrice et du second-membre
  600. C
  601.       CALL ECMO(MTAB3,'MATELM','MATRIK',MATRIK)
  602.       TYPE = ' '
  603.       CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO4)
  604.       IF (TYPE.NE.'CHPOINT ') THEN
  605.          CALL ECMO(MTAB1,'SMBR','CHPOINT ',MCHPOI)
  606.       ELSE
  607.          CALL ECROBJ('CHPOINT ',MCHPO4)
  608.          CALL ECROBJ('CHPOINT ',MCHPOI)
  609.          CALL PRFUSE
  610.          CALL LIROBJ('CHPOINT ',MCHPOI,1,IRET)
  611.          IF (IERR.NE.0) RETURN
  612.          CALL ECMO(MTAB1,'SMBR','CHPOINT ',MCHPOI)
  613.       ENDIF
  614. C     write(6,*) 'IKAS IVOL IKH IKT IKP',IKAS,IVOL1,IKH,IKT,IKP
  615.       RETURN
  616.       END
  617.  
  618.  
  619.  
  620.  
  621.  
  622.  
  623.  
  624.  
  625.  
  626.  
  627.  
  628.  
  629.  
  630.  
  631.  
  632.  
  633.  
  634.  
  635.  
  636.  
  637.  

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