Télécharger la plaquette Cast3M


fr en

Télécharger echi2.eso

Retour à la liste

Numérotation des lignes : 

echi2

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

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