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

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