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

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