Télécharger la plaquette Cast3M


fr en

Télécharger idmat2.eso

Retour à la liste

Numérotation des lignes : 

idmat2

  1. C IDMAT2    SOURCE    OF166741  24/10/07    21:15:26     12016          
  2.       SUBROUTINE IDMAT2(IPMODE,ICARA,NUDIR1,NUMP1,NUMP2,
  3.      1                               NUDIR2,NUMP3,ANG,ANG2,IPCARA,RFLAG)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. *--------------------------------------------------------------------*
  9. *       CREATION DU MCHAML CORRESPONDANT A UN MATERIAU ORTHOTROPE    *
  10. *                APPELE PAR MATCAR                                   *
  11. *--------------------------------------------------------------------*
  12. *                                                                    *
  13. *  ENTREES:                                                          *
  14. *  --------                                                          *
  15. *                                                                    *
  16. *     IPMODE   POINTEUR SUR UN MMODEL                                *
  17. *     ICARA    POINTEUR SUR UN MCHELM DE CARACTERISTIQUE (INCOMPLET) *
  18. *     NUDIR1   NUMERO DE LA DIRECTIVE UTILISE:"DIRECTION"OU RADIAL"  *
  19. *     NUMP1    NUMERO DU POINT P1 ASSOCIE A LA DIRECTIVE NIDIR1      *
  20. *     NUMP2    NUMERO DU POINT P2 ASSOCIE A LA DIRECTIVE NIDIR1      *
  21. *     NUDIR2   NUMERO DE LA DIRECTIVE UTILISE "PARALLELE" "PERPENDIC"*
  22. *              "INCLINE"                                             *
  23. *     NUMP3    NUMERO DU POINT P ASSOCIE A LA DIRECTIVE INCLINE      *
  24. *     ANG      ANGLE UTILISE DANS LES DIRECTIONS D ORTHOTROPIE       *
  25. *               (EN RADIAN)                                          *
  26. *     ANG2     idem ANG mais pour rotation hors plan en 2D fourier   *
  27. *                                                                    *
  28. *  SORTIES:                                                          *
  29. *  --------                                                          *
  30. *                                                                    *
  31. *     IPCARA   POINTEUR SUR UN MCHELM MATERIAU                       *
  32. *                                                                    *
  33. *                                                                    *
  34. *  AUTEUR JM CAMPENON LE 29 08 90                                    *
  35. *                                                                    *
  36. * ANISOTROPIE DANS LES ELEMENTS MASSIFS,  P. DOWLATYARI OCT. 90      *
  37. *                                                                    *
  38. *--------------------------------------------------------------------*
  39. *
  40.  
  41. -INC PPARAM
  42. -INC CCOPTIO
  43. -INC CCHAMP
  44. -INC SMCHAML
  45. -INC SMINTE
  46. -INC SMELEME
  47. -INC SMMODEL
  48. C
  49.       SEGMENT INFO
  50.        INTEGER INFELL(JG)
  51.       ENDSEGMENT
  52. C
  53.       SEGMENT XVAL
  54.          REAL*8 CVAL(NPG2,NEL2),SVAL(NPG2,NEL2)
  55.       ENDSEGMENT
  56. C
  57.       SEGMENT YVAL
  58.          REAL*8 VLOC1(IDIM2,NPG2,NEL2),VLOC2(IDIM2,NPG2,NEL2)
  59.       ENDSEGMENT
  60. C
  61.       INTEGER NUDIR1,NUMP1,NUMP2,NUDIR2,NUMP3
  62.       LOGICAL RFLAG
  63.       REAL*8 ANG
  64.       INTEGER NPG2,IPVAL
  65.       PARAMETER ( NINF=3 )
  66.       INTEGER INFOS(NINF)
  67.       CHARACTER*8 CMATE,CHARIN
  68.       CHARACTER*(NCONCH) CONM
  69. C
  70.       IPINF=0
  71.       IPINF2=0
  72. C
  73. C     ACTIVATION DU MCHELM
  74. C
  75.       MCHEL2=ICARA
  76.       SEGACT MCHEL2
  77. C
  78. C     CREATION DU MCHELM
  79. C
  80.       N1=MCHEL2.ICHAML(/1)
  81.       L1=16
  82.       N3=6
  83.       SEGINI MCHEL1
  84.       IPCARA=MCHEL1
  85.       MCHEL1.TITCHE=MCHEL2.TITCHE
  86.       MCHEL1.IFOCHE=MCHEL2.IFOCHE
  87. C
  88. C     BOUCLE SUR LES <> SOUS ZONES
  89. C
  90.       MMODEL=IPMODE
  91.       NSOUS=KMODEL(/1)
  92. C
  93. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES
  94. C
  95.       isous=0
  96.       DO 10 kSOUS=1,NSOUS
  97.       IMODEL=KMODEL(kSOUS)
  98.            if (NEFMOD.EQ.259) go to 10
  99.       isous=isous+1
  100. c                                       AM  4/5/93
  101.          MINTE=0
  102. C
  103.          MCHEL1.IMACHE(ISOUS)=MCHEL2.IMACHE(ISOUS)
  104.          MCHEL1.CONCHE(ISOUS)=MCHEL2.CONCHE(ISOUS)
  105.          DO 1 I=1,N3
  106.             MCHEL1.INFCHE(ISOUS,I)=MCHEL2.INFCHE(ISOUS,I)
  107.  1       CONTINUE
  108. C
  109.          IPMAIL=IMAMOD
  110.          CONM  =CONMOD
  111.          NFOR=FORMOD(/2)
  112.          NMAT=MATMOD(/2)
  113. C
  114. C        DANS LE CAS DE CONVECTION ON NE REMPLIT PAS MATMOD,
  115. C        ON SAUTE DONC CE CAS LA
  116. C
  117.          ITHER=0
  118.          iplc=0
  119.          iplr=0
  120.          ipls=0
  121.          IF(formod(1).eq.'THERMIQUE') then
  122.            ITHER=1
  123.            call place(matmod,nmat,iplc,'CONVECTION')
  124.            call place(matmod,nmat,iplr,'RAYONNEMENT')
  125.            call place(matmod,nmat,ipls,'SOURCE')
  126.          endif
  127.          MATE=1
  128.          IF (iplr+iplc+ipls.eq.0) THEN
  129. *           CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  130.            MATE = IMATEE
  131.            INAT = INATUU
  132.            CMATE = CMATEE
  133.             IF (CMATE.EQ.' ') THEN
  134.                CALL ERREUR(251)
  135.                RETURN
  136.             ENDIF
  137.          ENDIF
  138. C
  139. C        COQUE INTEGREE OU PAS ?
  140. C
  141.          NPINT=INFMOD(1)
  142. C_______________________________________________________________________
  143. C
  144. C        TRAITEMENT PARTICULIER POUR LES MATERIAU ORTHOTROPE OU ANISOT.
  145. C_______________________________________________________________________
  146. C
  147.          IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4.OR.RFLAG)THEN
  148.             MELE=NEFMOD
  149.             MELEME=IPMAIL
  150.             SEGACT MELEME
  151.             NBELEM=NUM(/2)
  152.             NBNN=NUM(/1)
  153.             CALL IDENT (IPMAIL,CONM,ICARA,0,INFOS,IRTD)
  154.             IF (IRTD.EQ.0) THEN
  155.              SEGSUP,MCHEL1
  156.              RETURN
  157.             ENDIF
  158. C
  159. C           INFORMATION SUR L ELEMENT FINI
  160. C
  161.             MFR  =NUMMFR(MELE)
  162. C
  163.             IF (MFR.EQ.75) THEN
  164.               CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  165.               IF (IERR.NE.0) THEN
  166.                  SEGSUP,MCHEL1
  167.                  RETURN
  168.               ENDIF
  169.               INFO=IPINF
  170.               NBPGAU = INFELL(6)
  171.                 segsup info
  172.             ELSEIF (MFR.EQ.1.OR.MFR.EQ.31) THEN
  173.               NBPGAU=1
  174.               NLG=NUMGEO(MELE)
  175.               CALL RESHPT (NBPGAU,NBNN,NLG,MELE,NPINT,IPT1,IRT1)
  176.               MINTE=IPT1
  177.             ELSEIF(MFR.EQ.45)THEN
  178.               NBPGAU=1
  179.               NLG=NUMGEO(MELE)
  180. C         on va récuperer le maillage des sommet pour le calcul
  181. C         des fonctions de formes dans le cas DARCY
  182.                CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  183.                CHARIN = 'MAILLAGE'
  184.                CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  185.                IF (IERR.NE.0) RETURN
  186.                IPT2 = IOBRE
  187.                SEGACT IPT2
  188.                MELEME=IPT2
  189.                IF(IPT2.LISOUS(/1).NE.0)THEN
  190.                    MELEME= IPT2.LISOUS(ISOUS)
  191.                    SEGACT MELEME
  192.                ENDIF
  193.               NBNN=NUM(/1)
  194.               CALL RESHPT (NBPGAU,NBNN,NLG,NLG,NPINT,IPT1,IRT1)
  195.               MINTE=IPT1
  196.             ELSEIF(MFR.EQ.33)THEN
  197. *              CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  198.               IF (IERR.NE.0) THEN
  199.                  SEGSUP,MCHEL1
  200.                  RETURN
  201.               ENDIF
  202.               NBPGAU=1
  203.               MINTE=INFMOD(4)
  204.             ELSEIF(MFR.EQ.3.OR.MFR.EQ.9.OR.MFR.EQ.5.OR.MFR.EQ.35) THEN
  205.               IF(ITHER.EQ.0)THEN
  206.                  if(infmod(/1).lt.5)then
  207.                 CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  208.                 IF (IERR.NE.0) THEN
  209.                   SEGSUP,MCHEL1
  210.                   RETURN
  211.                 ENDIF
  212.                 INFO=IPINF
  213.                 NBPGAU=INFELL(6)
  214.                 MINTE=INFELL(11)
  215.                 MINTE1=INFELL(12)
  216.                 segsup info
  217.                 else
  218.                 NBPGAU=INFELE(6)
  219.                 MINTE=INFMOD(5)
  220.                 MINTE1=INFMOD(8)
  221.                 endif
  222.               ELSE
  223.                 CALL TSHAPE(MELE,'GAUSS',IPT1)
  224.                 MINTE=IPT1
  225.                 SEGACT,MINTE
  226.                 NBPGAU=POIGAU(/1)
  227.                 IF(MFR.EQ.5)THEN
  228.                  CALL TSHAPE(MELE,'NOEUD',IPT2)
  229.                  MINTE1=IPT2
  230.                 ELSE
  231.                  MINTE1=0
  232.                 ENDIF
  233.               ENDIF
  234.             ENDIF
  235. *
  236. *           CAS 'RADIAL'  EN MASSIF
  237. *           ON CHERCHE LES POINTS DE GAUSS
  238. *
  239.             MINTE2=0
  240.             IF(NUDIR1.EQ.2.AND.
  241.      .         (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33.OR.MFR.EQ.45)) THEN
  242.                 melele=mele
  243.                 IF (MFR.EQ.45)melele=nlg
  244.                 if(infmod(/1).lt.5) then
  245.                   CALL ELQUOI(melele,0,3,IPINF2,IMODEL)
  246.                   IF (IERR.NE.0) THEN
  247.                   SEGSUP,MCHEL1
  248.                   RETURN
  249.                   ENDIF
  250.                   INFO=IPINF2
  251.                   MINTE2=INFELL(11)
  252.                   segsup info
  253.                 else
  254.                   minte2=infmod(5)
  255.                 endif
  256.               SEGACT MINTE2
  257.               NBPGA2=MINTE2.POIGAU(/1)
  258.             ENDIF
  259. C
  260. C           VERIFICATION DE LA COHERENCE DES INFORMATIONS
  261. C
  262.             IF (MFR.EQ.3.AND.IDIM.NE.3) THEN
  263. c           coque mince 2D: pas de mot-cle ou DIRE accepte : RADI refuse
  264.                IF (NUDIR1.NE.0.AND.NUDIR1.NE.1) THEN
  265.                   CALL ERREUR(21)
  266.                   GOTO 9990
  267.                ENDIF
  268.                NUDIR1=1
  269. c           coque mince 2D: INCLINE refuse
  270. c                IF (NUDIR2.EQ.3) THEN
  271. c                   CALL ERREUR(21)
  272. c                   GOTO 9990
  273. c                ENDIF
  274.             ELSE
  275. *
  276.              IF (NUDIR1.EQ.0) THEN
  277. C              DIRECTIONS D ORTHOTROPIE NON FOURNIES
  278.                CALL ERREUR(346)
  279.                GOTO 9990
  280.              ENDIF
  281.             ENDIF
  282.             IF (NUDIR2.EQ.0) THEN
  283. C              OPTION PARALLELE PAR DEFAUT
  284.                NUDIR2=1
  285.             ENDIF
  286.             IF(MFR.EQ.35)THEN
  287.               IF(NUDIR1.EQ.2)THEN
  288. *    CETTE DEFINITION DU REPERE D'ORTH. N'EST PAS VALABLE POUR
  289. *    LES ELEMENTS JOINTS (CAR ILS SONT PLANS)
  290.                CALL ERREUR (523)
  291.                 GO TO 9990
  292.               ENDIF
  293.             ENDIF
  294. C_______________________________________________________________________
  295. C
  296. C_______________________________________________________________________
  297. C
  298.       MCHAM2=MCHEL2.ICHAML(ISOUS)
  299.       SEGACT MCHAM2
  300.       NCOMP=MCHAM2.NOMCHE(/2)
  301.       N2=NCOMP
  302. C
  303. C     CREATION DU MCHAML : ON PREVOIT ICI QUE L'ON DOIT CREER 2 OU 6
  304. C                          COMPOSANTES SUPPLEMENTAIRES
  305. C
  306.       IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9.OR.MFR.EQ.35) THEN
  307.         N2=NCOMP+2
  308.       ELSEIF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33
  309.      &         .OR.MFR.EQ.45.OR.MFR.EQ.75) THEN
  310.         IF (IDIM.EQ.2) THEN
  311.           IF(IFOUR.EQ.1) THEN
  312.             IDIM2=3
  313.             N2=NCOMP+6
  314.           ELSE
  315.             IDIM2=2
  316.             N2=NCOMP+2
  317.           ENDIF
  318.         ELSE 
  319.           IDIM2=3
  320.           N2=NCOMP+6
  321.         ENDIF
  322.       ENDIF
  323.       SEGINI MCHAM1
  324.       MCHEL1.ICHAML(ISOUS)=MCHAM1
  325. C
  326. C     ON RECOPIE TOUS LES NOMS DE COMPOSANTE DE 1 A NCOMP
  327. C
  328.       IPEPAI=0
  329.       IPEXCE=0
  330.       DO 100 ICOMP=1,NCOMP
  331.          MCHAM1.NOMCHE(ICOMP)=MCHAM2.NOMCHE(ICOMP)
  332.          MCHAM1.TYPCHE(ICOMP)=MCHAM2.TYPCHE(ICOMP)
  333.          MELVA2=MCHAM2.IELVAL(ICOMP)
  334.          IF(MFR.EQ.5)THEN
  335.           IF(MCHAM2.NOMCHE(ICOMP).EQ.'EPAI')THEN
  336.            IPEPAI=MELVA2
  337.           ELSEIF(MCHAM2.NOMCHE(ICOMP).EQ.'EXCE')THEN
  338.            IPEXCE=MELVA2
  339.           ENDIF
  340.          ENDIF
  341.          SEGACT MELVA2
  342.          IF (MCHAM2.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  343.             N1PTEL=MELVA2.VELCHE(/1)
  344.             N1EL  =MELVA2.VELCHE(/2)
  345.             N2PTEL=0
  346.             N2EL  =0
  347. C
  348.             SEGINI MELVA1
  349.             MCHAM1.IELVAL(ICOMP)=MELVA1
  350.             DO 13 J=1,N1PTEL
  351.                DO 131 K=1,N1EL
  352.                   MELVA1.VELCHE(J,K)=MELVA2.VELCHE(J,K)
  353.  131           CONTINUE
  354.  13         CONTINUE
  355.          ELSE
  356.             N2PTEL=MELVA2.IELCHE(/1)
  357.             N2EL  =MELVA2.IELCHE(/2)
  358.             N1PTEL=0
  359.             N1EL  =0
  360.             SEGINI MELVA1
  361. C
  362.             MCHAM1.IELVAL(ICOMP)=MELVA1
  363.             DO 14 J=1,N2PTEL
  364.                DO 141 K=1,N2EL
  365.                   MELVA1.IELCHE(J,K)=MELVA2.IELCHE(J,K)
  366.  141           CONTINUE
  367.  14         CONTINUE
  368.          ENDIF
  369.  100  CONTINUE
  370.       IF(MFR.EQ.5.AND.IPEPAI.EQ.0)THEN
  371. *DANS LE CAS DES ELEMENTS COQUES EPAISSES ORTHOTROPES IL FAUT DONNER
  372. *L'EPAISSEUR EN MEME TEMPS QUE LES PROPRIETES MATERIELLES
  373.          CALL ERREUR (526 )
  374.             DO 311 ICOMP=1,NCOMP
  375.              MELVA2=MCHAM2.IELVAL(ICOMP)
  376.              MELVA1=MCHAM1.IELVAL(ICOMP)
  377.              SEGSUP,MELVA1
  378.  311       CONTINUE
  379.             SEGSUP MCHAM1
  380.             GOTO 9990
  381.       ENDIF
  382. C_______________________________________________________________________
  383. C
  384. C        ON TRAITE ICI LES COMPOSANTES 'V1X' ET 'V1Y'POUR LES ELEMENTS
  385. C        COQUES ET 'V1X','V1Y','V1Z','V2X','V2Y','V2Z' POUR LES MASSIF
  386. C_______________________________________________________________________
  387. C
  388. C_______________________________________________________________________
  389. C
  390. C     -- TRAITEMENT PARTICULIER SELON LE TYPE DES ELEMENTS --
  391. C_______________________________________________________________________
  392. C
  393. C
  394.       IF(MFR.EQ.3.OR.MFR.EQ.9.OR.MFR.EQ.35)THEN
  395.          IF (NUDIR1.EQ.1) THEN
  396.             NPG2=1
  397.          ENDIF
  398.          IF (NUDIR1.EQ.2) THEN
  399.             NPG2=NBPGAU
  400.          ENDIF
  401. C
  402.          IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.49.OR.MELE.EQ.93
  403.      .   .OR.MELE.EQ.87.OR.MELE.EQ.88.OR.MELE.EQ.128) THEN
  404.             ICALC=0
  405.          ELSEIF (MELE.EQ.44) THEN
  406.             ICALC=1
  407.          ENDIF
  408. C_______________________________________________________________________
  409. C
  410. C        LE FLAG ICALC SERT A INDIQUER L OPTION DE CALCUL A CHOISIR
  411. C        DANS LA ROUTINE IDMAT3  (IDEM MATEO2 ET COBIOR POUR MATE)
  412. C_______________________________________________________________________
  413. C
  414.           IPVAL=0
  415.           CALL IDMAT3 (NUDIR1,NUMP1,NUDIR2,NUMP3,ANG,
  416.      1                MELEME,MINTE,NPG2,ICALC,MFR,IPVAL)
  417.           IF (IERR.NE.0) THEN
  418.             DO 300 ICOMP=1,NCOMP
  419.              MELVA2=MCHAM2.IELVAL(ICOMP)
  420.              MELVA1=MCHAM1.IELVAL(ICOMP)
  421.              SEGSUP,MELVA1
  422.  300       CONTINUE
  423.             SEGSUP MCHAM1
  424.             GOTO 9990
  425.           ENDIF
  426.        ELSEIF(MFR.EQ.5)THEN
  427.           NPG2=NBPGAU
  428.           IPVAL=0
  429.           CALL IDMAT5(NUDIR1,NUMP1,NUDIR2,NUMP3,ANG,
  430.      1            MELEME,MINTE,MINTE1,IPEPAI,IPEXCE,NPG2,ITHER,IPVAL)
  431.           IF (IERR.NE.0) THEN
  432.             DO 312 ICOMP=1,NCOMP
  433.              MELVA2=MCHAM2.IELVAL(ICOMP)
  434.              MELVA1=MCHAM1.IELVAL(ICOMP)
  435.              SEGSUP,MELVA1
  436.  312       CONTINUE
  437.             SEGSUP MCHAM1
  438.             GOTO 9990
  439.           ENDIF
  440.        ELSEIF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33.OR.MFR.EQ.45)THEN
  441.           IPVAL=0
  442.           NPG2=1
  443. cbp : afin d'interdire une description "3D" du repere local en 2D 
  444. c Fourier pour DARCY, on truande un peu via IFOUR qu'on met a 0 (=axi)
  445.           IFOUR1=IFOUR
  446.           if(MFR.EQ.45.and.IFOUR.eq.1) IFOUR=0
  447.           IF(NUDIR1.EQ.2) NPG2=NBPGA2
  448.           CALL IDMAT4(NUMP1,NUMP2,NUDIR1,NUDIR2,ANG,ANG2,
  449.      .                MELEME,MINTE,IPVAL,NPG2,MINTE2)
  450.           IFOUR=IFOUR1
  451.           IF (IERR.NE.0) THEN
  452.             DO 310 ICOMP=1,NCOMP
  453.              MELVA2=MCHAM2.IELVAL(ICOMP)
  454.              MELVA1=MCHAM1.IELVAL(ICOMP)
  455.              SEGSUP,MELVA1
  456.  310       CONTINUE
  457.             SEGSUP MCHAM1
  458.             GOTO 9990
  459.           ENDIF
  460.        ELSEIF (MFR.EQ.75)THEN
  461.           IPVAL=0
  462.           NPG2=NBPGAU
  463.           CALL IDMAT6(NUMP1,NUMP2,NUDIR1,NUDIR2,ANG,MELEME,
  464.      .                IPVAL,NPG2)
  465.           IF (IERR.NE.0) THEN
  466.             DO 375 ICOMP=1,NCOMP
  467.              MELVA2=MCHAM2.IELVAL(ICOMP)
  468.              MELVA1=MCHAM1.IELVAL(ICOMP)
  469.              SEGSUP,MELVA1
  470.  375       CONTINUE
  471.             SEGSUP MCHAM1
  472.             GOTO 9990
  473.           ENDIF
  474.         ELSE
  475.             MOTERR(5:8) = NOMTP(MELE)
  476.             MOTERR(1:4) = 'ORTH'
  477.             CALL ERREUR (71)
  478.             DO 320 ICOMP=1,NCOMP
  479.              MELVA2=MCHAM2.IELVAL(ICOMP)
  480.              MELVA1=MCHAM1.IELVAL(ICOMP)
  481.              SEGSUP,MELVA1
  482.  320       CONTINUE
  483.             SEGSUP MCHAM1
  484.             GOTO 9990
  485.         ENDIF
  486. C
  487.          IF (MFR.EQ.3 .OR.MFR.EQ.9.OR.MFR.EQ.5.OR.MFR.EQ.35 )THEN
  488. C
  489. C          ON CREE LES COMPOSANTES V1X ET V1Y
  490. C
  491.            IF (RFLAG) THEN
  492.              MCHAM1.NOMCHE(N2-1  )='W1X '
  493.              MCHAM1.NOMCHE(N2    )='W1Y '
  494.            ELSE
  495.              MCHAM1.NOMCHE(N2-1  )='V1X '
  496.              MCHAM1.NOMCHE(N2    )='V1Y '
  497.            ENDIF
  498.            MCHAM1.TYPCHE(N2-1  )='REAL*8'
  499.            MCHAM1.TYPCHE(N2    )='REAL*8'
  500. C
  501. C          REMPLISSAGE DU SEGMENT MELVA1 CONTENANT LES COMPOSANTES
  502. C
  503.            N1PTEL=NPG2
  504.            N1EL  = NBELEM
  505.            N2PTEL=0
  506.            N2EL  =0
  507. C
  508.            XVAL=IPVAL
  509.            SEGACT XVAL
  510. C
  511.            SEGINI MELVA1
  512.            MCHAM1.IELVAL(N2-1)=MELVA1
  513.            DO 1110 IB=1,NBELEM
  514.               DO 1111 IGAU=1,NPG2
  515.                  IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  516.                  IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
  517.                  MELVA1.VELCHE(IGMN,IBMN)=CVAL(IGAU,IB)
  518.  1111         CONTINUE
  519.  1110      CONTINUE
  520. C
  521.            SEGINI MELVA1
  522.            MCHAM1.IELVAL(N2)=MELVA1
  523.            DO 2110 IB=1,NBELEM
  524.               DO 2111 IGAU=1,NPG2
  525.                  IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  526.                  IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
  527.                  MELVA1.VELCHE(IGMN,IBMN)=SVAL(IGAU,IB)
  528.  2111         CONTINUE
  529.  2110      CONTINUE
  530. C
  531.         SEGSUP XVAL
  532.  
  533.       ELSEIF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33
  534.      &       .OR.MFR.EQ.45.OR.MFR.EQ.75)THEN
  535. C
  536. C        ON CREE LES COMPOSANTES V1X,V1Y,V1Z, . . .
  537. C
  538. cbp       IF(IDIM.EQ.2)THEN
  539. c        IF(IDIM.EQ.2.AND.((MFR.NE.1.AND.MFR.NE.31).OR.IFOUR.NE.1))THEN
  540.        IF(IDIM2.EQ.2)THEN
  541.          NCOMPV=2
  542.          IF (RFLAG) THEN
  543.            MCHAM1.NOMCHE(N2-1  )='W1X '
  544.            MCHAM1.NOMCHE(N2    )='W1Y '
  545.          ELSE
  546.            MCHAM1.NOMCHE(N2-1  )='V1X '
  547.            MCHAM1.NOMCHE(N2    )='V1Y '
  548.          ENDIF
  549. C
  550. cbp       ELSEIF(IDIM.EQ.3)THEN
  551.        ELSE
  552.          NCOMPV=6
  553. C
  554.          IF (RFLAG) THEN
  555.            MCHAM1.NOMCHE(N2-5  )='W1X '
  556.            MCHAM1.NOMCHE(N2-4  )='W1Y '
  557.            MCHAM1.NOMCHE(N2-3  )='W1Z '
  558.            MCHAM1.NOMCHE(N2-2  )='W2X '
  559.            MCHAM1.NOMCHE(N2-1  )='W2Y '
  560.            MCHAM1.NOMCHE(N2    )='W2Z '
  561.          ELSE
  562.            MCHAM1.NOMCHE(N2-5  )='V1X '
  563.            MCHAM1.NOMCHE(N2-4  )='V1Y '
  564.            MCHAM1.NOMCHE(N2-3  )='V1Z '
  565.            MCHAM1.NOMCHE(N2-2  )='V2X '
  566.            MCHAM1.NOMCHE(N2-1  )='V2Y '
  567.            MCHAM1.NOMCHE(N2    )='V2Z '
  568.          ENDIF
  569. C
  570.        ENDIF
  571.  
  572.          DO 200 ICOMP =1,NCOMPV
  573.          MCHAM1.TYPCHE(N2-(NCOMPV-ICOMP))='REAL*8'
  574.  200     CONTINUE
  575. C
  576. C        REMPLISSAGE DU SEGMENT MELVA1 CONTENANT LES COMPOSANTES
  577. C
  578.          N1PTEL=NPG2
  579.          N1EL  =NBELEM
  580.          N2PTEL=0
  581.          N2EL  =0
  582.          YVAL=IPVAL
  583.          SEGACT YVAL
  584. C
  585.          DO 210 ICOMP=1,NCOMPV
  586.            SEGINI MELVA1
  587.            MCHAM1.IELVAL(N2-(NCOMPV-ICOMP))=MELVA1
  588.            DO 220 IB=1,NBELEM
  589.              DO 230 IG=1,NPG2
  590.                IF(ICOMP.LE.3)THEN
  591.                  MELVA1.VELCHE(IG,IB)=VLOC1(ICOMP,IG,IB)
  592.                ELSE
  593.                  MELVA1.VELCHE(IG,IB)=VLOC2((ICOMP-3),IG,IB)
  594.                ENDIF
  595.  230         CONTINUE
  596.  220       CONTINUE
  597.  210     CONTINUE
  598.          SEGSUP YVAL
  599. *
  600.       ENDIF
  601. C
  602. C_______________________________________________________________________
  603. C_______________________________________________________________________
  604. C
  605.          ELSE
  606. C
  607. C           ON RECOPIE LE CHAMELEM ICARA DANS LE CHAMELEM IPCARA
  608. C
  609.             DO 17 I=1,N3
  610.                MCHEL1.INFCHE(ISOUS,I)=MCHEL2.INFCHE(ISOUS,I)
  611.  17         CONTINUE
  612. C
  613. C           ACTIVATION DU MCHAML
  614. C
  615.             MCHAM2=MCHEL2.ICHAML(ISOUS)
  616.             SEGACT MCHAM2
  617.             N2=MCHAM2.NOMCHE(/2)
  618. C
  619.             SEGINI MCHAM1
  620.             MCHEL1.ICHAML(ISOUS)=MCHAM1
  621.             DO 2 ICOMP=1,N2
  622.                MCHAM1.NOMCHE(ICOMP)=MCHAM2.NOMCHE(ICOMP)
  623.                MCHAM1.TYPCHE(ICOMP)=MCHAM2.TYPCHE(ICOMP)
  624. C
  625. C              ACTIVATION DU MELVAL
  626. C
  627.                MELVA2=MCHAM2.IELVAL(ICOMP)
  628.                SEGACT MELVA2
  629.                IF (MCHAM2.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  630.                   N1PTEL=MELVA2.VELCHE(/1)
  631.                   N1EL  =MELVA2.VELCHE(/2)
  632.                   N2PTEL=0
  633.                   N2EL  =0
  634. C
  635.                   SEGINI MELVA1
  636.                   MCHAM1.IELVAL(ICOMP)=MELVA1
  637.                   DO 5 J=1,N1PTEL
  638.                      DO 51 K=1,N1EL
  639.                         MELVA1.VELCHE(J,K)=MELVA2.VELCHE(J,K)
  640.  51                  CONTINUE
  641.  5                CONTINUE
  642.                ELSE
  643.                   N2PTEL=MELVA2.IELCHE(/1)
  644.                   N2EL  =MELVA2.IELCHE(/2)
  645.                   N1PTEL=0
  646.                   N1EL  =0
  647.                   SEGINI MELVA1
  648. C
  649.                   MCHAM1.IELVAL(ICOMP)=MELVA1
  650.                   DO 4 J=1,N2PTEL
  651.                      DO 42 K=1,N2EL
  652.                         MELVA1.IELCHE(J,K)=MELVA2.IELCHE(J,K)
  653.  42                  CONTINUE
  654.  4                CONTINUE
  655.                ENDIF
  656.  2          CONTINUE
  657.          ENDIF
  658. C
  659. C   DESACTIVATION DES SEGMENTS
  660. C
  661.  10   CONTINUE
  662.       RETURN
  663. C
  664. C     ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR
  665. C
  666.  9990 CONTINUE
  667.       SEGSUP MCHEL1
  668.       END
  669.  
  670.  
  671.  
  672.  
  673.  
  674.  
  675.  
  676.  

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