Télécharger la plaquette Cast3M


fr en

Télécharger chasup.eso

Retour à la liste

Numérotation des lignes : 

chasup

  1. C CHASUP    SOURCE    OF166741  24/10/07    21:15:08     12016          
  2.  
  3. C---------------------------------------------------------------------
  4.  
  5. C     ENTREES:
  6. C
  7. C       IPMODL     Pointeur sur un MMODEL
  8. C       IPOI1      Pointeur sur un MCHAML
  9. C       IPLAC      Indique le type de support demandé :
  10. C               1  scalaire aux NOEUDS
  11. C               2  scalaire au  CENTRE DE GRAVITE
  12. C               3  scalaire aux points d'integration de la RAIDEUR
  13. C               4  scalaire aux points d'integration de la MASSE
  14. C               5  scalaire aux points de CONTRAINTES
  15. C
  16. C      AM  14/6/07  SI IPLAC EST NEGATIF, ON RECUPERE UN CHAMP QUI
  17. C                   NE CONTIENT PAS LES COMPOSANTES COMPLEXES (NON SCALAIRES)
  18. C                   QU'ON A N'A PAS PU CHANGER
  19. C                   SINON, ON SORT EN ERREUR
  20. C
  21. C     SORTIE:
  22. C
  23. C       IPOI2      Pointeur sur un MCHAML
  24. C       IRET      =0 Si tout est ok
  25. C                    Sinon contient le numero d'erreur
  26. C
  27. C     I.MONNIER le 31.05.90
  28. C
  29. C---------------------------------------------------------------------
  30.       SUBROUTINE CHASUP(IPMODL,IPOI1,IPOI2,IRET,IPLAC)
  31.  
  32.       IMPLICIT INTEGER(I-N)
  33.       IMPLICIT REAL*8(A-H,O-Z)
  34.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC SMMODEL
  38. -INC SMCHAML
  39. -INC SMELEME
  40. -INC SMINTE
  41. -INC SMCOORD
  42.       CHARACTER*8 CHARIN,CHARTY,MO24a,MO24b
  43.       CHARACTER*(LOCOMP) MOCOMP
  44.  
  45.       SEGMENT SWORK
  46.         REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN)
  47.         REAL*8 SHP(6,NBNN) ,XE(3,NBNN)
  48.       ENDSEGMENT
  49.  
  50.       SEGMENT SWORK2
  51.         INTEGER LETAB(N22)
  52.       ENDSEGMENT
  53. *
  54. *     NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
  55. *     N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
  56. *
  57.       SEGMENT  INFO
  58.         INTEGER INFELL(JG)
  59.       ENDSEGMENT
  60.  
  61. *      write(ioimp,*) 'coucou chasup'
  62. *      write(ioimp,*) 'iplac=',iplac
  63. *      write(ioimp,*) ' MCHAML'
  64. *      call ecrobj('MCHAML  ',IPOI1)
  65. *      call prlist
  66. *      CALL ACTOBJ('MCHAML  ',IPOI1,1)
  67. *      write(ioimp,*) ' MCHAML'
  68. *      call ecrobj('MMODEL  ',IPMODL)
  69. *      call prlist
  70. *      CALL ACTOBJ('MMODEL  ',IPMODL,1)
  71.  
  72.       IRET  =0
  73.       IPOIN1=0
  74.       call oooeta(mcoord,ieta,imod)
  75. C
  76. C     ACTIVATION DU MODELE
  77. C
  78.       MMODEL=IPMODL
  79.       NSOUS1=KMODEL(/1)
  80. C
  81. C     ACTIVATION DES MCHELM
  82. C
  83.       MCHEL1 =IPOI1
  84.       NSOUS=MCHEL1.ICHAML(/1)
  85.       IF(NSOUS.GT.NSOUS1)THEN
  86. *  on va essayer de reduir le champ
  87.          call reduaf(mchel1,mmodel,mchel2,0,ire,kerre)
  88. **     if (ire.ne.1) then
  89. **       call erreur(kerre)
  90. **       IRET=553
  91. **       RETURN
  92. **     endif
  93.          if (ire.eq.1)  mchel1=mchel2
  94.          NSOUS=MCHEL1.ICHAML(/1)
  95.       ENDIF
  96.       N1=NSOUS
  97.       L1=MCHEL1.TITCHE(/1)
  98.       N3=MCHEL1.INFCHE(/2)
  99.       NINF=N3
  100.       IF (N3.LT.6) N3=6
  101.       SEGINI MCHELM
  102.       TITCHE=MCHEL1.TITCHE
  103.       IFOCHE=IFOUR
  104.  
  105.       IPOI2=MCHELM
  106.       iresu=0
  107. C
  108. C  ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
  109. C
  110.       DO 100 ISOUS=1,NSOUS
  111.  
  112.          IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  113.          CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  114.          DO IP=1,NINF
  115.             INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP)
  116.          ENDDO
  117. C
  118. C       MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
  119. C
  120.          MELEME=IMACHE(ISOUS)
  121.          MO24a =CONCHE(ISOUS)
  122.  
  123.          INS=0
  124.          DO IO=1,NSOUS1
  125.             IMODEL=KMODEL(IO)
  126.             IPMAIL=IMAMOD
  127. C
  128. C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  129.             CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY           ')
  130.             IF (IDARC.NE.0)THEN
  131.                CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  132.                CHARIN = 'MAILLAGE'
  133.                CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  134.                IF (IERR.NE.0) RETURN
  135.                IPT1 = IOBRE
  136.                IPMAIL= IOBRE
  137.                IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
  138.                   IPMAIL= IPT1.LISOUS(ISOUS)
  139.                ENDIF
  140.             ENDIF
  141.             IF (IPMAIL.EQ.MELEME) INS=INS+1
  142.          ENDDO
  143.  
  144.          DO IO=1,NSOUS1
  145.             IMODEL=KMODEL(IO)
  146. C
  147.             IPMAIL=imodel.IMAMOD
  148. C
  149. C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  150.             CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY           ')
  151.             IF(IDARC.NE.0)THEN
  152.                CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  153.                CHARIN = 'MAILLAGE'
  154.                CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  155.                IF (IERR.NE.0) RETURN
  156.                IPT1 = IOBRE
  157.                IPMAIL= IOBRE
  158.                IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
  159.                   IPMAIL= IPT1.LISOUS(ISOUS)
  160.                ENDIF
  161.             ENDIF
  162.  
  163.             MO24b=imodel.CONMOD
  164.             IF (IPMAIL.EQ.MELEME.AND.(INS.GE.1.OR.MO24a.EQ.MO24b))GOTO
  165.      $           160
  166.          ENDDO
  167. *
  168.          IRET=472
  169.          SEGSUP MCHELM
  170.          RETURN
  171. *
  172.  160     CONTINUE
  173.          MELE=NEFMOD
  174.  
  175. c*         write(6,*) 'chasup - mele ',mele,imodel,ipmail
  176. *  on saute si element sans les supports
  177.          if(mele.eq.22 ) go to 100
  178.          if(mele.eq.259) go to 100
  179.          if(mele.eq.107) go to 100
  180.          if(mele.eq.165) go to 100
  181.          if(mele.eq.261) go to 100
  182. *
  183. *      DANS LE CAS DES COQUES INTEGREES ON SORT EN ERREUR
  184. *
  185.          IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN
  186.             MINTE1=0
  187.             IPLACA=0
  188.          ELSE
  189.             MINTE1=MCHEL1.INFCHE(ISOUS,4)
  190.             IPLACA=MCHEL1.INFCHE(ISOUS,6)
  191.          ENDIF
  192. C
  193.          ithdm = 0
  194.          if (formod(1).eq.'LIAISON         ') then
  195.             IPLAC1 = 1
  196.          else
  197.             IPLAC1 = ABS(IPLAC)
  198.             IF ( IPLAC1 .EQ. 6 ) ithdm = 1
  199. C le modele contient t il de la thermique OU diffusion OU metallurgie ?
  200. C  ==> le segment d'integration est particulier
  201.             IF ( FORMOD(1).EQ.'THERMIQUE       ' .OR.
  202.      &           FORMOD(1).EQ.'DIFFUSION       ' .OR.
  203.      &           FORMOD(1).EQ.'METALLURGIE     ' ) THEN
  204.                ithdm = 1
  205.                icov  = 0
  206.                nmat = matmod(/2)
  207.                CALL PLACE(matmod,nmat,iray,'RAYONNEMENT     ')
  208.                IF (icov+iray.EQ.0) THEN
  209.                  IF ( IPLAC1 .GT. 2 ) IPLAC1 = 6
  210.                ENDIF
  211.  
  212.                IF(MELE .EQ. 265)THEN
  213. C             Cas des JOI1 ==> Ressorts THERMIQUES
  214. C             ============
  215.                   ithdm = 0
  216.                   IPLAC1 = 1
  217.                ENDIF
  218.  
  219.             ENDIF
  220.          endif
  221. C
  222.          IF (ithdm.NE.0 .AND. IPLAC1.GT.1) THEN
  223.             IF (IPLAC1.EQ.1) CALL TSHAPE(MELE,'NOEUD  ',IPMINT)
  224.             IF (IPLAC1.EQ.2) CALL TSHAPE(MELE,'GRAVITE',IPMINT)
  225.             IF (IPLAC1.EQ.6) CALL TSHAPE(MELE,'GAUSS  ',IPMINT)
  226.             IF (IERR .NE. 0) GOTO 665
  227.             MINTE=IPMINT
  228.             MELGEO=NUMGEO(MELE)
  229.          ELSE
  230.             if(2+iplac1.gt.infmod(/1))then
  231.                CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
  232.                IF ( IERR .NE. 0) GOTO 665
  233.                INFO=IPTR2
  234.                MINTE=INFELL(11)
  235.                MELGEO=INFELL(14)
  236.                SEGSUP,INFO
  237.             else
  238.                minte=infmod(2+iplac1)
  239.                MELGEO=INFELE(14)
  240.             endif
  241.          ENDIF
  242.          INFCHE(ISOUS,4)=MINTE
  243.          IF(IPLAC1.EQ.1)INFCHE(ISOUS,4)=0
  244.          INFCHE(ISOUS,6)=IPLAC1
  245. C
  246. C     ON RECUPERE LE NOMBRE D ELEMENTS
  247. C
  248.          NBNN  =NUM(/1)
  249.          NBELEM=NUM(/2)
  250. C
  251. C     ON RECUPERE LE NOMBRE DE POINTS SUPPORT
  252. C     NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
  253. C
  254.          IF(MINTE1.NE.0)THEN
  255.             NBPGA1 = MINTE1.SHPTOT(/3)
  256.          ELSE
  257.             NBPGA1=NBNN
  258.          ENDIF
  259.          if (minte.eq.0) then
  260.             call erreur(5)
  261.             return
  262.          endif
  263.          NBPGAU = SHPTOT(/3)
  264.          nbpga1=max(nbpga1,nbpgau)
  265. C
  266.          NEL   =NBELEM
  267.          SEGINI SWORK
  268. C
  269. C       PREPARATION POUR CREATION DU MCHAML
  270. C
  271.          MCHAM1=MCHEL1.ICHAML(ISOUS)
  272. C
  273.          N22 = MCHAM1.NOMCHE(/2)
  274. *
  275. *     SI IPLAC < 0, ON CHERCHE LE NOMBRE DE COMPOSANTES A CONSERVER
  276. *
  277.          SEGINI SWORK2
  278. *
  279.          IF(IPLAC.GE.0) THEN
  280.             N2 = N22
  281.             DO ICOMP=1,N22
  282.                LETAB(ICOMP) = ICOMP
  283.             ENDDO
  284. *
  285.          ELSE
  286. *
  287. *         BOUCLE SUR LES COMPOSANTES
  288. *
  289.             JECO = 0
  290.             DO ICOMP=1,N22
  291. C
  292.                CHARTY=MCHAM1.TYPCHE(ICOMP)
  293.                MELVA1=MCHAM1.IELVAL(ICOMP)
  294.                LETAB(ICOMP) = 0
  295. *
  296.                IF(CHARTY(1:6).EQ.'REAL*8') THEN
  297.                   JECO = JECO + 1
  298.                   LETAB(ICOMP) = JECO
  299.                ENDIF
  300. *
  301. *            cas de variables complexes
  302. *
  303.                IF(CHARTY(1:8).EQ.'POINTEUR') THEN
  304.                   N2PTE1=MELVA1.IELCHE(/1)
  305. *
  306. * ... Comme on ne sait pas extrapoler ou interpoler de variables
  307. *     composées, on n'en accepte qu'une par élément ...
  308.  
  309.                   IF(N2PTE1.EQ.1) THEN
  310.                      JECO = JECO + 1
  311.                      LETAB(ICOMP) = JECO
  312.                   ENDIF
  313.                ENDIF
  314.             ENDDO
  315.             N2 = JECO
  316. *
  317.          ENDIF
  318. *
  319. *    CREATION DU MCHAML
  320. *
  321.          SEGINI MCHAML
  322.          iresu=iresu+1
  323.          ICHAML(iresu)=MCHAML
  324. C
  325. C       BOUCLE SUR LES COMPOSANTES EN ENTREE
  326. C
  327.          DO 180 ICOMP=1,N22
  328. C
  329.             JCOMP = LETAB(ICOMP)
  330.             IF(JCOMP.EQ.0) GO TO 180
  331.  
  332.             NOMCHE(JCOMP)=MCHAM1.NOMCHE(ICOMP)
  333.             TYPCHE(JCOMP)=MCHAM1.TYPCHE(ICOMP)
  334. C
  335.             MELVA1=MCHAM1.IELVAL(ICOMP)
  336. *
  337. *  RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
  338. *
  339.             IF(TYPCHE(JCOMP)(1:6).EQ.'REAL*8') THEN
  340.                N1PTE1=MELVA1.VELCHE(/1)
  341.                IF (N1PTE1.EQ.1) THEN
  342.                   N1PTEL=1
  343.                ELSE
  344.                   N1PTEL=NBPGAU
  345.                ENDIF
  346.                N1EL  =MELVA1.VELCHE(/2)
  347. *
  348. *  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
  349. *
  350.                IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN
  351.                   SEGSUP SWORK,SWORK2,MCHAML
  352.                   IRET=146
  353.                   MOTERR(1:8)='CHASUP  '
  354.                   GO TO 665
  355.                ENDIF
  356. *
  357.                N1PAUX=N1PTE1
  358. C
  359. C-----------------------------------------------------------------------
  360. C                     PETIT TEST POUR LE COQ4
  361. C       SI LE NOMBRE DE POINTS DE GAUSS VAUT 5 , ON NE PREND QUE
  362. C       LES 4 PREMIERS , LE 5-EME SERVANT UNIQUEMENT AU CISAILLEMENT
  363. C
  364.                IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4
  365. C-----------------------------------------------------------------------
  366. C
  367.             ELSE
  368.                N1PTEL=0
  369.                N1EL=0
  370.             ENDIF
  371. *
  372. *     ... Et dans le cas de variables complexes ...
  373. *
  374.             IF(TYPCHE(JCOMP)(1:8).EQ.'POINTEUR') THEN
  375.                N2PTE1=MELVA1.IELCHE(/1)
  376.                IF (N2PTE1.EQ.1) THEN
  377.                   N2PTEL=1
  378.                ELSE
  379.                   N2PTEL=NBPGAU
  380.                ENDIF
  381.                N2EL  =MELVA1.IELCHE(/2)
  382. *
  383. * ... Comme on ne sait pas extrapoler ou interpoler de variables
  384. *     composées, on n'en accepte qu'une par élément ...
  385.  
  386. *           IF(N2PTEL.NE.1) THEN
  387. *             SEGSUP SWORK,SWORK2,MCHAML
  388. *             IRET=755
  389. *             GO TO 665
  390. *           ENDIF
  391. *
  392. *  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
  393. *
  394.                IF(N2EL.NE.NEL.AND.N2EL.NE.1.AND.NEL.NE.1) THEN
  395.                   SEGSUP SWORK,SWORK2,MCHAML
  396.                   IRET=146
  397.                   MOTERR(1:8)='CHASUP  '
  398.                   GO TO 665
  399.                ENDIF
  400.  
  401.             ELSE
  402.                N2PTEL=0
  403.                N2EL=0
  404.             ENDIF
  405.             SEGINI MELVAL
  406.             IELVAL(JCOMP)=MELVAL
  407. *
  408. *  TRAITEMENT IMMEDIAT SI CHAMP CONSTANT
  409. *
  410. *         if(iplac1.eq.4) write(6,*)' n2ptel n1ptel',n2ptel,n1ptelq
  411.             IF(n2ptel.ne.0) then
  412.                IF(N2PTEL.EQ.1) THEN
  413.                   DO 4119 IEL=1,N2EL
  414.                      IELCHE(1,IEL)=MELVA1.IELCHE(1,IEL)
  415.  4119             CONTINUE
  416. C*        ELSE IF (N2PTEL.NE.1) THEN
  417.                ELSE
  418.                   IF (MINTE.NE.MINTE1. AND. IPLAC1.NE.IPLACA) THEN
  419.                      SEGSUP SWORK,SWORK2,MCHAML
  420.                      IRET=755
  421.                      GO TO 665
  422.                   ENDIF
  423.                   DO 4109 IGAU=1,N2PTEL
  424.                      DO 41091 IEL=1,N2EL
  425.                         IELCHE(IGAU,IEL)=MELVA1.IELCHE(IGAU,IEL)
  426. 41091                CONTINUE
  427.  4109             CONTINUE
  428.                ENDIF
  429.             else
  430.                IF(N1PTE1.EQ.1) THEN
  431.                   DO 4120 IEL=1,N1EL
  432.                      VELCHE(1,IEL)=MELVA1.VELCHE(1,IEL)
  433.  4120             CONTINUE
  434. *
  435.                ELSE
  436. *
  437. *          write (6,*) melva1.velche(/1),melva1.velche(/2)
  438.  
  439.                   DO 3120 IEL=1,NEL
  440.                      IF(IEL.GT.1.AND.N1EL.EQ.1) GO TO 3130
  441.                      DO 3121 IGAU=1,N1PTE1
  442.                         VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
  443.  3121                CONTINUE
  444.  
  445. *          write(6,*) 'MINTE1 = ',minte1
  446.  
  447. C
  448. C      1-ER CAS : LE CHAMELEM N'EST PAS AUX NOEUDS
  449. C
  450.                      IF(MINTE1.NE.0)THEN
  451. C
  452. C           MEME SUPPORT? ( attention test sur iplaca et iplac1 pour DKT)
  453. C
  454. *            write(6,*) ' meme support?',minte,minte1,iplac1,iplaca
  455.                         IF(MINTE.EQ.MINTE1. OR. IPLAC1.eq.IPLACA)
  456.      $                       THEN
  457.                            DO 3124 IGAU=1,N1PTE1
  458.                               VELCHE(IGAU,IEL)=VAL1(IGAU)
  459.  3124                      CONTINUE
  460. C
  461. C           SUPPORTS DIFFERENTS
  462. C
  463.                         ELSE
  464. C
  465. C   COQUE INTEGREE OU PAS ?
  466. C
  467.                            NPINT=INFMOD(1)
  468.                            IF (NPINT.NE.0.AND.NPINT.NE.1)THEN
  469.                               IRET = 19
  470.                               SEGSUP SWORK,SWORK2,MCHAML,MELVAL
  471.                               GO TO 665
  472.                            ENDIF
  473. C
  474.                            if (ieta.ne.1) then
  475.                               ieta=1
  476.                               segact mcoord
  477.                            endif
  478.                            CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  479.                            CALL QUEDIM(MELGEO,KERRE)
  480.                            CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL
  481.      $                          ,N1PAUX,NBNN,SWORK,IPOIN1,KERRE)
  482.                            IF(KERRE.NE.0) THEN
  483.                               IRET=KERRE
  484.                               SEGSUP SWORK,SWORK2,MCHAML,MELVAL
  485.                               GO TO 665
  486.                            ENDIF
  487. *
  488.                            DO 3122 IGAU=1,N1PTEL
  489.                               VELCHE(IGAU,IEL)=VAL2(IGAU)
  490.  3122                      CONTINUE
  491.                         ENDIF
  492. C
  493. C      2-EME CAS : LE CHAMELEM EST AUX NOEUDS
  494. C
  495.                      ELSE
  496. *
  497. *  AM  1/4/16 CAS PARTICULIER DES JOINTS
  498. *
  499.                         IF( MELGEO.EQ.12.OR.MELGEO.EQ.13
  500.      &                       .OR.MELGEO.EQ.29.OR.MELGEO.EQ.30
  501.      &                       .OR.MELGEO.EQ.31) THEN
  502. *
  503.                            IF(((IPLACA.EQ.0.OR.IPLACA.EQ.1).AND.
  504.      $                          IPLAC1.EQ.1).AND.(N1PTEL.EQ.N1PTE1))
  505.      $                          THEN
  506.                               DO IGAU=1,N1PTE1
  507.                                  VELCHE(IGAU,IEL)=VAL1(IGAU)
  508.                               ENDDO
  509.                            ELSE
  510. *
  511.                               IDECA=0
  512.                               IF(MELGEO.EQ.29) IDECA=2
  513.                               IF(MELGEO.EQ.30) IDECA=3
  514.                               IF(MELGEO.EQ.31) IDECA=4
  515.                               NBNOU=NBNN-IDECA
  516.                               NBNOV=SHPTOT(/2)-IDECA
  517. *
  518.                               MOCOMP=NOMCHE(JCOMP)
  519.                               IF (MOCOMP.EQ.'P  '.OR.
  520.      &                            MOCOMP.EQ.'PQ '.OR.
  521.      &                            MOCOMP.EQ.'TP '    ) THEN
  522.                                  DO IGAU=1,N1PTEL
  523.                                     VALG=0.D0
  524.                                     DO INO=1,IDECA
  525.                                        INO1 = NBNOU + INO
  526.                                        INO2 = NBNOV + INO
  527.                                        VALG=VALG+SHPTOT(1,INO2,IGAU)
  528.      $                                      *VAL1(INO1)
  529.                                     ENDDO
  530.                                     VELCHE(IGAU,IEL)=VALG
  531.                                  ENDDO
  532.  
  533.                               ELSE
  534.                                  DO IGAU=1,N1PTEL
  535.                                     VALG=0.D0
  536.                                     DO INO=1,NBNOU
  537.                                        VALG=VALG+SHPTOT(1,INO,IGAU)
  538.      $                                      *VAL1(INO)
  539.                                     ENDDO
  540.                                     VELCHE(IGAU,IEL)=VALG/2.D0
  541.                                  ENDDO
  542.                               ENDIF
  543.                            ENDIF
  544.  
  545.                         ELSE
  546.                            DO IGAU=1,N1PTEL
  547.                               VALG=0.D0
  548.                               DO INO=1,NBNN
  549.                                  VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO)
  550.                               ENDDO
  551.                               VELCHE(IGAU,IEL)=VALG
  552.                            ENDDO
  553.                         ENDIF
  554.  
  555.                      ENDIF
  556.  3120             CONTINUE
  557.  3130             CONTINUE
  558.  
  559.                ENDIF
  560.             endif
  561.  180     CONTINUE
  562.          SEGSUP SWORK,SWORK2
  563.  
  564.  100  CONTINUE
  565.       if (iresu.ne.nsous) then
  566.          n1=iresu
  567.          segadj mchelm
  568.       endif
  569.  
  570.  665  CONTINUE
  571. c      return
  572.       END
  573.  
  574.  
  575.  

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