Télécharger la plaquette Cast3M


fr en

Télécharger fiss.eso

Retour à la liste

Numérotation des lignes : 

fiss

  1. C FISS      SOURCE    CB215821  24/04/12    21:15:59     11897          
  2.        SUBROUTINE FISS
  3.        IMPLICIT INTEGER(I-N)
  4.        IMPLICIT REAL*8 (A-H,O-Z)
  5. C__________________________________________________________________
  6. C      operateur FUITE:
  7. C      Calcul du debit air-vapeur dans une fissure plane
  8. C
  9. C
  10. C__________________________________________________________________
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMELEME
  14. -INC SMCHAML
  15. -INC SMCOORD
  16. -INC SMCHPOI
  17. -INC SMLENTI
  18. -INC SMMODEL
  19. -INC SMTABLE
  20. C
  21.       SEGMENT MAVAL
  22.         REAL*8 VAL(NVAL)
  23.       ENDSEGMENT
  24. C
  25.       SEGMENT PTRAV1
  26.        INTEGER KASN(NNPT),KG(NNPT)
  27.        REAL*8 XNC(NNPT),TP(NNPT),EP(NNPT),BP(NNPT)
  28.       ENDSEGMENT
  29.       SEGMENT PTRAV2
  30.        REAL*8 XX(NMX)
  31.        REAL*8 XP(NMX),XPV(NMX),XT(NMX),XY(NMX),XU(NMX)
  32.        REAL*8 XQ(NMX),XQA(NMX),XQW(NMX),XHF(NMX),XRE(NMX),XDH(NMX)
  33.        REAL*8 ZP(NNPT),ZPV(NNPT),ZT(NNPT),ZY(NNPT),ZU(NNPT)
  34.        REAL*8 ZQ(NNPT),ZQA(NNPT),ZQW(NNPT),ZHF(NNPT),ZRE(NNPT),ZDH(NMX)
  35.        REAL*8 ZTRA(NNPT)
  36.       ENDSEGMENT
  37. C
  38.       INTEGER GPARF
  39.       CHARACTER*8 CMATE
  40.       CHARACTER*12 CMAT1,CMAT2,CMAT3
  41.       CHARACTER*(NCONCH) CONM
  42.       CHARACTER*8 MCO3,MCO4,NOM
  43.       CHARACTER*(LOCOMP) MCO1,MCO2,MOT
  44.       REAL*8 VALCL(5)
  45.       POINTEUR MCHMAT.MCHELM
  46.       POINTEUR PCHMAT.MCHAML
  47.       POINTEUR DCHMAT.MELVAL
  48.       POINTEUR PCOMP.MAVAL
  49. C
  50.        CHARACTER*10 MOALIR
  51.        CHARACTER*8  TYPOBJ
  52.        CHARACTER*28  MOTTAB
  53.        CHARACTER*72 CHARRE
  54.        LOGICAL LOGIN,LOGRE
  55.        REAL*8  XVALIN,XVALRE
  56. C
  57.        TYPOBJ='        '
  58.        KIMP=IIMPI
  59.        QINI = -1.
  60. C***********************************************************************
  61. C lecture obligatoire de l objet modele
  62. C
  63.       IPMODL=0
  64.       CALL LIROBJ('MMODEL  ',IPMODL,1,IRET)
  65.       CALL ACTOBJ('MMODEL  ',IPMODL,1)
  66.       IF (IERR.NE.0) RETURN
  67. C
  68. C***********************************************************************
  69. C lecture obligatoire du champ de proprietes materielles
  70. C
  71.       IPCHA1 = 0
  72.       CALL LIROBJ('MCHAML  ',IPIN,1,IRET1)
  73.       CALL ACTOBJ('MCHAML  ',IPIN,1)
  74.       IF (IERR.NE.0) RETURN      
  75.       CALL REDUAF(IPIN,IPMODL,IPCHA1,0,IR,KER)
  76.       IF(IR   .NE. 1) CALL ERREUR(KER)
  77.       IF(IERR .NE. 0) RETURN
  78.  
  79. C verification de l egalite des supports du modele et du ch prop mat
  80.       call rayn1(IPMODL,IPCHA1)
  81. C
  82. C***********************************************************************
  83. C lecture obligatoire de la table des conditions aux limites
  84. C
  85.       IPCHE3 = 0
  86.       IPCHA2 = 0
  87.       IPCHA3 = 0
  88.       IPCHA4 = 0
  89.       CALL LIROBJ('TABLE   ',IPTAB,1,IRETOU)
  90.       IF(IERR.NE.0) RETURN
  91.       MTABLE = IPTAB
  92.       SEGACT MTABLE
  93.       NDIMTAB = MLOTAB
  94. C
  95.       MOTTAB='PRESSION_TOTALE_AMONT'
  96.       CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  97.      .            TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  98.       PE = XVALRE
  99.       MOTTAB='PRESSION_VAPEUR_AMONT'
  100.       CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  101.      .            TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  102.       PVE = XVALRE
  103.       MOTTAB='TEMPERATURE_AMONT'
  104.       CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  105.      .            TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  106.       TE = XVALRE
  107.       MOTTAB='PRESSION_TOTALE_AVAL'
  108.       CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  109.      .            TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  110.       PS = XVALRE
  111.       MOTTAB='TEMPERATURE_PAROI'
  112.       TYPOBJ='        '
  113.       CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  114.      .            TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA2)
  115.       MOTTAB='OUVERTURE'
  116.       TYPOBJ='        '
  117.       CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  118.      .            TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA3)
  119. *
  120.       IF(NDIMTAB.EQ.7) THEN
  121.         MOTTAB='DEBIT_INITIAL'
  122.         TYPOBJ='        '
  123.         CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,
  124.      .              IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  125.         IF(TYPOBJ.EQ.'FLOTTANT') THEN
  126.           QINI = XVALRE
  127.         ELSE
  128.           MOTTAB='ETENDUE'
  129.           TYPOBJ='        '
  130.           CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,
  131.      .                IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA4)
  132.         ENDIF
  133.       ENDIF
  134. *
  135.       IF(NDIMTAB.EQ.8) THEN
  136.         MOTTAB='DEBIT_INITIAL'
  137.         TYPOBJ='        '
  138.         CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,
  139.      .              IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  140.         QINI = XVALRE
  141.         MOTTAB='ETENDUE'
  142.         TYPOBJ='        '
  143.         CALL ACCTAB(IPTAB,'MOT     ',IVALIN,XVALIN,MOTTAB,LOGIN,
  144.      .              IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA4)
  145.       ENDIF
  146.       SEGDES MTABLE
  147. C***********************************************************************
  148. C               ACTIVATION DU MODELE
  149. C               --------------------
  150.       MMODEL = IPMODL
  151.       SEGACT MMODEL
  152. C      NSOUS = KMODEL(/1)
  153.  
  154.       IMODEL=KMODEL(1)
  155.       SEGACT IMODEL
  156. C
  157. C     initialisations
  158.       IPMAIL= IMAMOD
  159.       NFOR  = FORMOD(/2)
  160.       NMAT  = MATMOD(/2)
  161. C
  162. C     verification de la formulation
  163.       CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  164.       IF (CMATE.EQ.' ')THEN
  165.          CALL ERREUR(251)
  166.          IRET=0
  167.          RETURN
  168.       ENDIF
  169. C     lecture de la formulation
  170.       CMAT1 = CMATE(1:2)
  171.       CMAT2 = CMATE(3:4)
  172.       CMAT3 = CMATE(5:8)
  173.       IF (CMAT1.EQ.'MA')THEN
  174.          XW = 0.D0
  175.       ELSE
  176.          XW = 1.D0
  177.       ENDIF
  178.       IF (CMAT2.EQ.'PA')THEN
  179.          GPARF = 1
  180.       ELSE
  181.          GPARF = 0
  182.       ENDIF
  183. C
  184. C***********************************************************************
  185. C               ACTIVATION DU MCHELM ch prop mat
  186. C               --------------------
  187.       MCHMAT = IPCHA1
  188.       SEGACT MCHMAT
  189. C      NBS = MCHMAT.IMACHE(/1)
  190. C pas de boucle sur les modeles elementaires car NSOUS=1
  191. C pas de boucle sur les maillages elementaires car NBS=1
  192. C     initialilsations
  193.       RUG = 0.
  194. C     lecture des prop materielles
  195.       PCHMAT = MCHMAT.ICHAML(1)
  196.       SEGACT PCHMAT
  197.       NBS2 = PCHMAT.IELVAL(/1)
  198.       NVAL = NBS2
  199.       SEGINI PCOMP
  200. C boucle sur le nb de composantes du ch prop mat
  201.       DO 10 I =1,NBS2
  202.          MOT = PCHMAT.NOMCHE(I)
  203.          DCHMAT = PCHMAT.IELVAL(I)
  204.          SEGACT DCHMAT
  205. C         N1PTEL = DCHMAT.VELCHE(/1)
  206. C         N1EL = DCHMAT.VELCHE(/2)
  207.          PCOMP.VAL(I) = DCHMAT.VELCHE(1,1)
  208.          IF(MOT.EQ.'RUGO')   RUG   = PCOMP.VAL(I)
  209.          IF(MOT.EQ.'REC ')   RECU  = PCOMP.VAL(I)
  210.          IF(MOT.EQ.'FK  ')   XKUL  = PCOMP.VAL(I)
  211.          IF(MOT.EQ.'FA  ')   XKUT1 = PCOMP.VAL(I)
  212.          IF(MOT.EQ.'FB  ')   XKUT2 = PCOMP.VAL(I)
  213.          IF(MOT.EQ.'FC  ')   XKUT3 = PCOMP.VAL(I)
  214.          IF(MOT.EQ.'FD  ')   XKUT4 = PCOMP.VAL(I)
  215.  10   CONTINUE
  216.  
  217.       IF (CMAT3.EQ.'BLAS') THEN
  218.           RECU = -1D5
  219.           XKUL = 0.
  220.           XKUT1 = 0.
  221.           XKUT2 = 0.
  222.           XKUT3 = 0.
  223.           XKUT4 = 0.
  224.       ELSE IF (CMAT3.EQ.'COLE')THEN
  225.           RECU = -1D5
  226.           XKUL = 0.
  227.           XKUT1 = 0.
  228.           XKUT2 = 0.
  229.           XKUT3 = 0.
  230.           XKUT4 = 0.
  231. *         ELSE IF (CMAT3.EQ.'ENT1')THEN
  232. *          RECU = PCOMP.VAL(2)
  233.       ELSE IF (CMAT3.EQ.'ENT2')THEN
  234.           RECU =-1D0*RECU
  235.          ELSE IF (CMAT3.EQ.'ENT3')THEN
  236.           RECU = -1D6
  237.           XKUT1 = 0.
  238.           XKUT2 = 0.
  239.           XKUT3 = 0.
  240.           XKUT4 = 0.
  241.       ELSE IF (CMAT3.EQ.'ENT4')THEN
  242.           RECU = -1D7
  243.           XKUT1 = 0.
  244.           XKUT2 = 0.
  245.           XKUT3 = 0.
  246.           XKUT4 = 0.
  247.       ENDIF
  248.       SEGSUP PCOMP
  249. C
  250. C*********************************************************************
  251. C               TRAITEMENT des 2 champs ep et tp
  252. C               --------------------------------
  253.        IPT2=IPMAIL
  254.  
  255.        SEGACT IPT2
  256.        NBSO = IPT2.LISOUS(/1)
  257.        IF (NBSO.NE.0) THEN
  258.          CALL ERREUR(25)
  259.          RETURN
  260.        ENDIF
  261.        NEL = IPT2.NUM(/2)
  262.  
  263.        NPT2 = IPT2.NUM(/1)
  264.        IF (NPT2.NE.2) THEN
  265.           CALL ERREUR(16)
  266.           RETURN
  267.        ENDIF
  268.  
  269. C     segment de travail 1
  270.  
  271.        NNPT = NEL + 1
  272.        SEGINI PTRAV1
  273.  
  274.        XNC(1)=0.D0
  275.        KG(1)= IPT2.NUM(1,1)
  276.  
  277. C   calcul des abscisses curvilignes
  278.  
  279.        SEGACT,MCOORD
  280.        IF (IDIM.EQ.1) THEN
  281.          DO I =1,NEL
  282.              KG(I+1) = IPT2.NUM(2,I)
  283.              IREF1 = (IDIM+1)*(IPT2.NUM(1,I)-1)
  284.              IREF2 = (IDIM+1)*(IPT2.NUM(2,I)-1)
  285.              DX1 = XCOOR(IREF2+1)-XCOOR(IREF1+1)
  286.              XNC(I+1) = XNC(I) + DX1
  287.          ENDDO
  288.        ENDIF
  289.        IF (IDIM.EQ.2) THEN
  290.          DO I =1,NEL
  291.              KG(I+1) = IPT2.NUM(2,I)
  292.              IREF1 = (IDIM+1)*(IPT2.NUM(1,I)-1)
  293.              IREF2 = (IDIM+1)*(IPT2.NUM(2,I)-1)
  294.              DX1 = XCOOR(IREF2+1)-XCOOR(IREF1+1)
  295.              DX2 = XCOOR(IREF2+2)-XCOOR(IREF1+2)
  296.              DXC = SQRT(DX1*DX1+DX2*DX2)
  297.              XNC(I+1) = XNC(I) + DXC
  298.          ENDDO
  299.        ENDIF
  300.        IF (IDIM.EQ.3) THEN
  301.          DO I =1,NEL
  302.              KG(I+1) = IPT2.NUM(2,I)
  303.              IREF1 = (IDIM+1)*(IPT2.NUM(1,I)-1)
  304.              IREF2 = (IDIM+1)*(IPT2.NUM(2,I)-1)
  305.              DX1 = XCOOR(IREF2+1)-XCOOR(IREF1+1)
  306.              DX2 = XCOOR(IREF2+2)-XCOOR(IREF1+2)
  307.              DX3 = XCOOR(IREF2+3)-XCOOR(IREF1+3)
  308.              DXC = SQRT(DX1*DX1+DX2*DX2+DX3*DX3)
  309.              XNC(I+1) = XNC(I) + DXC
  310.          ENDDO
  311.        ENDIF
  312.        SEGDES,MCOORD
  313.        XL = XNC(NNPT)
  314.        DO I =1,NNPT
  315.          XNC(I)=XNC(I)/XL
  316.        ENDDO
  317. * recherche du plus petit DX
  318.        DXMINAV = 0.01
  319.        DO I =1,NNPT-1
  320.              DXNC = XNC(I+1)-XNC(I)
  321.              DXMIN = MIN(DXNC,DXMINAV)
  322.              DXMINAV = DXMIN
  323.        ENDDO
  324.        DX = DXMIN/5.D0
  325.        IF(KIMP.GE.1) THEN
  326.          WRITE(6,*) 'fiss : taille relative de maille fluide= ',DX
  327.        ENDIF
  328.  
  329. * segment de travail 2
  330.        NMX=3*INT(1.D0/DX)
  331.        SEGINI PTRAV2
  332.  
  333.        IF (KIMP.EQ.2) THEN
  334.            WRITE(6,*) 'fiss : XL ',XL
  335.            WRITE(6,*) (XNC(I),I=1,NNPT)
  336.            WRITE(6,*) 'fiss : KG(I) = ',(KG(I),I=1,NNPT)
  337.        ENDIF
  338.  
  339. C activation segment MCHPO1 (chpoint Temperature et ouverture)
  340.        CALL FUCHPO(IPCHA2,IPCHA3,IRETOU)
  341.        MCHPO1=IRETOU
  342.        SEGACT MCHPO1
  343.        NSOUPO = MCHPO1.IPCHP(/1)
  344.  
  345.        IF(NSOUPO.NE.1) THEN
  346.           CALL ERREUR(25)
  347.           RETURN
  348.        ENDIF
  349.  
  350.        MSOUP1 = MCHPO1.IPCHP(1)
  351.        SEGACT MSOUP1
  352.        NC = MSOUP1.NOHARM(/1)
  353.  
  354.        IF(NC.NE.2) THEN
  355.          CALL ERREUR(21)
  356.        RETURN
  357.        ENDIF
  358.  
  359.        IPT1 = MSOUP1.IGEOC
  360.        CALL KRIPAD(IPT1,MLENT1)
  361.        SEGACT IPT1, MLENT1
  362. C       NTOT = MLENT1.LECT(/1)
  363.  
  364.        MPOVA1 = MSOUP1.IPOVAL
  365.  
  366.        SEGACT MPOVA1
  367.        NNPT1 = MPOVA1.VPOCHA(/1)
  368. C
  369.        IF (NNPT1.NE.NNPT) THEN
  370.          CALL ERREUR(21)
  371.          RETURN
  372.        ENDIF
  373.  
  374.        DO I = 1,NNPT
  375.          KASN(I) = MLENT1.LECT(KG(I))
  376.        ENDDO
  377.  
  378. C    remplissage des tableaux classes
  379.  
  380.        MCO1=MSOUP1.NOCOMP(1)
  381.        MCO2=MSOUP1.NOCOMP(2)
  382.        IF (MCO1.EQ.'T   ') THEN
  383.          IF (MCO2.EQ.'OUV ') THEN
  384.             DO I=1,NNPT
  385.             TP(I) = MPOVA1.VPOCHA(KASN(I),1)
  386.             EP(I) = MPOVA1.VPOCHA(KASN(I),2)
  387.             ENDDO
  388.          ELSE
  389.             MOTERR= MCO2
  390.             CALL ERREUR(197)
  391.             RETURN
  392.          ENDIF
  393.        ELSEIF (MCO1.EQ.'OUV ') THEN
  394.          IF (MCO2.EQ.'T   ') THEN
  395.             DO I=1,NNPT
  396.             TP(I) = MPOVA1.VPOCHA(KASN(I),2)
  397.             EP(I) = MPOVA1.VPOCHA(KASN(I),1)
  398.             ENDDO
  399.          ELSE
  400.             MOTERR= MCO2
  401.             CALL ERREUR(197)
  402.             RETURN
  403.          ENDIF
  404.        ELSE
  405.             MOTERR= MCO1
  406.             CALL ERREUR(197)
  407.             RETURN
  408.        ENDIF
  409.        IF (IIMPI.EQ.2) THEN
  410.           write(6,*) 'fiss : TP= ',(TP(I),I=1,NNPT)
  411.           write(6,*) 'fiss : EP= ',(EP(I),I=1,NNPT)
  412.        ENDIF
  413. C cas etendue unite (champ d etendue non defini par utilisateur)
  414.        IF (IPCHA4.EQ.0) THEN
  415.           DO I=1,NNPT
  416.             BP(I) = 1.
  417.           ENDDO
  418.        ENDIF
  419. C activation segment MCHPO2 (chpoint Temperature et etendue)
  420.        IF (IPCHA4.GT.0) THEN
  421.        CALL FUCHPO(IPCHA2,IPCHA4,IRETOU)
  422.        MCHPO2=IRETOU
  423.        SEGACT MCHPO2
  424.        NSOUPO = MCHPO2.IPCHP(/1)
  425.  
  426.        IF(NSOUPO.NE.1) THEN
  427.           CALL ERREUR(25)
  428.           RETURN
  429.        ENDIF
  430.  
  431.        MSOUP2 = MCHPO2.IPCHP(1)
  432.        SEGACT MSOUP2
  433.        NC = MSOUP2.NOHARM(/1)
  434.  
  435.        IF(NC.NE.2) THEN
  436.          CALL ERREUR(21)
  437.        RETURN
  438.        ENDIF
  439.  
  440.        IPT2 = MSOUP2.IGEOC
  441.        CALL KRIPAD(IPT2,MLENT1)
  442.        SEGACT IPT2, MLENT1
  443. C       NTOT = MLENT1.LECT(/1)
  444.  
  445.        MPOVA2 = MSOUP2.IPOVAL
  446.  
  447.        SEGACT MPOVA2
  448.        NNPT1 = MPOVA2.VPOCHA(/1)
  449. C
  450.        IF (NNPT1.NE.NNPT) THEN
  451.          CALL ERREUR(21)
  452.          RETURN
  453.        ENDIF
  454.  
  455.        DO I = 1,NNPT
  456.          KASN(I) = MLENT1.LECT(KG(I))
  457.        ENDDO
  458.  
  459. C    remplissage des tableaux classes
  460.  
  461.        MCO1=MSOUP2.NOCOMP(1)
  462.        MCO2=MSOUP2.NOCOMP(2)
  463.        IF (MCO1.EQ.'T   ') THEN
  464.          IF (MCO2.EQ.'ETEN') THEN
  465.             DO I=1,NNPT
  466.             TP(I) = MPOVA2.VPOCHA(KASN(I),1)
  467.             BP(I) = MPOVA2.VPOCHA(KASN(I),2)
  468.             ENDDO
  469.          ELSE
  470.             MOTERR= MCO2
  471.             CALL ERREUR(197)
  472.             RETURN
  473.          ENDIF
  474.        ELSEIF (MCO1.EQ.'ETEN') THEN
  475.          IF (MCO2.EQ.'T   ') THEN
  476.             DO I=1,NNPT
  477.             TP(I) = MPOVA2.VPOCHA(KASN(I),2)
  478.             BP(I) = MPOVA2.VPOCHA(KASN(I),1)
  479.             ENDDO
  480.          ELSE
  481.             MOTERR= MCO2
  482.             CALL ERREUR(197)
  483.             RETURN
  484.          ENDIF
  485.        ELSE
  486.             MOTERR= MCO1
  487.             CALL ERREUR(197)
  488.             RETURN
  489.        ENDIF
  490.        IF (IIMPI.EQ.2) THEN
  491.           write(6,*) 'fiss : BP= ',(BP(I),I=1,NNPT)
  492.        ENDIF
  493.       ENDIF
  494.  
  495. C compatibilite de la loi de frottement avec la valeur de rugosite
  496.       DO I=1,NNPT
  497.         RUGD = RUG/(2.*EP(I))
  498.         IF (RUGD.GE.1e-4.AND.MATMOD(3).EQ.'POISEU_BLASIUS') THEN
  499.             MOTERR(1:12)= 'RUGO/2e'
  500.             REAERR(1) = RUGD
  501.             REAERR(2) = 0.0001
  502. C %m1:18 = %r1 superieur a %r2
  503.             CALL ERREUR(43)
  504.             RETURN
  505.         ENDIF
  506.         IF (RUGD.LT.1e-4.AND.MATMOD(3).EQ.'POISEU_COLEBROOK') THEN
  507.             MOTERR(1:18)= 'RUGO/2e'
  508.             REAERR(1) = RUGD
  509.             REAERR(2) = 0.0001
  510. C %m1:18 = %r1 inferieur a %r2
  511.             CALL ERREUR(41)
  512.             RETURN
  513.         ENDIF
  514.       ENDDO
  515. C
  516. C***********************************************************************
  517. C               CALCUL
  518. C               ------
  519.  
  520.       IF (GPARF.EQ.1) THEN
  521.  
  522.        CALL BECALC(PE,PVE,TE,PS,XL,DX,RUG,QINI,XW,NNPT,XNC,TP,EP,BP,
  523.      $  KIMP,NMX,NX,XX,XP,XPV,XT,XY,XU,XHF,XQ,XQW,XQA,XRE,XDH,RECU,
  524.      $  XKUL,XKUT1,XKUT2,XKUT3,XKUT4)
  525.        IF (IERR.NE.0) RETURN
  526.  
  527.        ELSE
  528.        CALL BECALC2(PE,PVE,TE,PS,XL,DX,RUG,QINI,XW,NNPT,XNC,TP,EP,BP,
  529.      $  KIMP,NMX,NX,XX,XP,XPV,XT,XY,XU,XHF,XQ,XQW,XQA,XRE,XDH,RECU,
  530.      $  XKUL,XKUT1,XKUT2,XKUT3,XKUT4)
  531.        IF (IERR.NE.0) RETURN
  532.  
  533.        ENDIF
  534.  
  535. C      creation des champs nodaux resultats
  536.  
  537.        CALL BYRETO(XX,XP,NX,ZP,XNC,NNPT,KASN,ZTRA)
  538.        CALL BYRETO(XX,XPV,NX,ZPV,XNC,NNPT,KASN,ZTRA)
  539.        CALL BYRETO(XX,XT,NX,ZT,XNC,NNPT,KASN,ZTRA)
  540.        CALL BYRETO(XX,XY,NX,ZY,XNC,NNPT,KASN,ZTRA)
  541.        CALL BYRETO(XX,XU,NX,ZU,XNC,NNPT,KASN,ZTRA)
  542.        CALL BYRETO(XX,XHF,NX,ZHF,XNC,NNPT,KASN,ZTRA)
  543.        CALL BYRETO(XX,XQ,NX,ZQ,XNC,NNPT,KASN,ZTRA)
  544.        CALL BYRETO(XX,XQA,NX,ZQA,XNC,NNPT,KASN,ZTRA)
  545.        CALL BYRETO(XX,XQW,NX,ZQW,XNC,NNPT,KASN,ZTRA)
  546.        CALL BYRETO(XX,XRE,NX,ZRE,XNC,NNPT,KASN,ZTRA)
  547.        CALL BYRETO(XX,XDH,NX,ZDH,XNC,NNPT,KASN,ZTRA)
  548.  
  549. C      ecriture du champoint multicomposante
  550.  
  551.        NC = 11
  552.        N = NNPT
  553.        SEGINI MPOVAL
  554.          DO I=1,NNPT
  555.          VPOCHA(I,1) = ZP(I)
  556.          VPOCHA(I,2) = ZPV(I)
  557.          VPOCHA(I,3) = ZT(I)
  558.          VPOCHA(I,4) = ZY(I)
  559.          VPOCHA(I,5) = ZU(I)
  560.          VPOCHA(I,6) = ZHF(I)
  561.          VPOCHA(I,7) = ZQ(I)
  562.          VPOCHA(I,8) = ZQA(I)
  563.          VPOCHA(I,9) = ZQW(I)
  564.          VPOCHA(I,10) = ZRE(I)
  565.          VPOCHA(I,11) = ZDH(I)
  566.          ENDDO
  567.  
  568.        SEGSUP PTRAV1
  569.        SEGSUP PTRAV2
  570.        SEGINI MSOUPO
  571.  
  572.          NOCOMP(1) = 'P   '
  573.          NOCOMP(2) = 'PV  '
  574.          NOCOMP(3) = 'TF  '
  575.          NOCOMP(4) = 'X   '
  576.          NOCOMP(5) = 'U   '
  577.          NOCOMP(6) = 'H   '
  578.          NOCOMP(7) = 'Q   '
  579.          NOCOMP(8) = 'QA  '
  580.          NOCOMP(9) = 'QE  '
  581.          NOCOMP(10)= 'RE  '
  582.          NOCOMP(11)= 'F   '
  583.  
  584.          IGEOC = IPT1
  585.          IPOVAL = MPOVAL
  586.  
  587.          DO I=1,NC
  588.          NOHARM(I) = MSOUP1.NOHARM(1)
  589.          ENDDO
  590.  
  591.        NSOUPO = 1
  592.        NAT = MCHPO1.JATTRI(/1)
  593.        SEGINI MCHPOI
  594.  
  595.          MTYPOI = MCHPO1.MTYPOI
  596.          MOCHDE = MCHPO1.MOCHDE
  597.          DO I=1,NAT
  598.          JATTRI(I) = MCHPO1.JATTRI(1)
  599.          ENDDO
  600.          IPCHP(1) = MSOUPO
  601.          IFOPOI = MCHPO1.IFOPOI
  602.  
  603.        CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  604.        CALL ECROBJ('CHPOINT ',MCHPOI)
  605.  
  606.        END
  607.  
  608.  
  609.  
  610.  
  611.  
  612.  
  613.  

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