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

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