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    CB215821  25/04/25    21:15:03     12250          
  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.  
  206. C               nmat = matmod(/2)
  207. C               CALL PLACE(matmod,nmat,icov,'CONVECTION')
  208. C               CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  209. C               IF (icov+iray.EQ.0) THEN
  210.                  IF ( IPLAC1 .GT. 2 ) IPLAC1 = 6
  211. C               ENDIF
  212.  
  213.                IF(MELE .EQ. 265)THEN
  214. C             Cas des JOI1 ==> Ressorts THERMIQUES
  215. C             ============
  216.                   ithdm = 0
  217.                   IPLAC1 = 1
  218.                ENDIF
  219.  
  220.             ENDIF
  221.          endif
  222. C
  223.          IF (ithdm.EQ.1 .AND. IPLAC1.GT.1) THEN
  224.             IPMINT = 0
  225.             IF (IPLAC1.EQ.1) CALL TSHAPE(MELE,'NOEUD  ',IPMINT)
  226.             IF (IPLAC1.EQ.2) CALL TSHAPE(MELE,'GRAVITE',IPMINT)
  227.             IF (IPLAC1.EQ.5) CALL TSHAPE(MELE,'GAUSS  ',IPMINT)
  228.             IF (IPLAC1.EQ.6) CALL TSHAPE(MELE,'GAUSS  ',IPMINT)
  229.             IF (IERR .NE. 0) GOTO 665
  230.             MINTE=IPMINT
  231.             MELGEO=NUMGEO(MELE)
  232.          ELSE
  233.             if(2+iplac1.gt.infmod(/1))then
  234.                CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
  235.                IF ( IERR .NE. 0) GOTO 665
  236.                INFO=IPTR2
  237.                MINTE=INFELL(11)
  238.                MELGEO=INFELL(14)
  239.                SEGSUP,INFO
  240.             else
  241.                minte=infmod(2+iplac1)
  242.                MELGEO=INFELE(14)
  243.             endif
  244.          ENDIF
  245.          INFCHE(ISOUS,4)=MINTE
  246.          IF(IPLAC1.EQ.1)INFCHE(ISOUS,4)=0
  247.          INFCHE(ISOUS,6)=IPLAC1
  248. C
  249. C     ON RECUPERE LE NOMBRE D ELEMENTS
  250. C
  251.          NBNN  =NUM(/1)
  252.          NBELEM=NUM(/2)
  253. C
  254. C     ON RECUPERE LE NOMBRE DE POINTS SUPPORT
  255. C     NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
  256. C
  257.          IF(MINTE1.NE.0)THEN
  258.             NBPGA1 = MINTE1.SHPTOT(/3)
  259.          ELSE
  260.             NBPGA1=NBNN
  261.          ENDIF
  262.          if (minte.eq.0) then
  263.             call erreur(5)
  264.             return
  265.          endif
  266.          NBPGAU = SHPTOT(/3)
  267.          nbpga1=max(nbpga1,nbpgau)
  268. C
  269.          NEL   =NBELEM
  270.          SEGINI SWORK
  271. C
  272. C       PREPARATION POUR CREATION DU MCHAML
  273. C
  274.          MCHAM1=MCHEL1.ICHAML(ISOUS)
  275. C
  276.          N22 = MCHAM1.NOMCHE(/2)
  277. *
  278. *     SI IPLAC < 0, ON CHERCHE LE NOMBRE DE COMPOSANTES A CONSERVER
  279. *
  280.          SEGINI SWORK2
  281. *
  282.          IF(IPLAC.GE.0) THEN
  283.             N2 = N22
  284.             DO ICOMP=1,N22
  285.                LETAB(ICOMP) = ICOMP
  286.             ENDDO
  287. *
  288.          ELSE
  289. *
  290. *         BOUCLE SUR LES COMPOSANTES
  291. *
  292.             JECO = 0
  293.             DO ICOMP=1,N22
  294. C
  295.                CHARTY=MCHAM1.TYPCHE(ICOMP)
  296.                MELVA1=MCHAM1.IELVAL(ICOMP)
  297.                LETAB(ICOMP) = 0
  298. *
  299.                IF(CHARTY(1:6).EQ.'REAL*8') THEN
  300.                   JECO = JECO + 1
  301.                   LETAB(ICOMP) = JECO
  302.                ENDIF
  303. *
  304. *            cas de variables complexes
  305. *
  306.                IF(CHARTY(1:8).EQ.'POINTEUR') THEN
  307.                   N2PTE1=MELVA1.IELCHE(/1)
  308. *
  309. * ... Comme on ne sait pas extrapoler ou interpoler de variables
  310. *     composées, on n'en accepte qu'une par élément ...
  311.  
  312.                   IF(N2PTE1.EQ.1) THEN
  313.                      JECO = JECO + 1
  314.                      LETAB(ICOMP) = JECO
  315.                   ENDIF
  316.                ENDIF
  317.             ENDDO
  318.             N2 = JECO
  319. *
  320.          ENDIF
  321. *
  322. *    CREATION DU MCHAML
  323. *
  324.          SEGINI MCHAML
  325.          iresu=iresu+1
  326.          ICHAML(iresu)=MCHAML
  327. C
  328. C       BOUCLE SUR LES COMPOSANTES EN ENTREE
  329. C
  330.          DO 180 ICOMP=1,N22
  331. C
  332.             JCOMP = LETAB(ICOMP)
  333.             IF(JCOMP.EQ.0) GO TO 180
  334.  
  335.             NOMCHE(JCOMP)=MCHAM1.NOMCHE(ICOMP)
  336.             TYPCHE(JCOMP)=MCHAM1.TYPCHE(ICOMP)
  337. C
  338.             MELVA1=MCHAM1.IELVAL(ICOMP)
  339. *
  340. *  RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
  341. *
  342.             IF(TYPCHE(JCOMP)(1:6).EQ.'REAL*8') THEN
  343.                N1PTE1=MELVA1.VELCHE(/1)
  344.                IF (N1PTE1.EQ.1) THEN
  345.                   N1PTEL=1
  346.                ELSE
  347.                   N1PTEL=NBPGAU
  348.                ENDIF
  349.                N1EL  =MELVA1.VELCHE(/2)
  350. *
  351. *  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
  352. *
  353.                IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN
  354.                   SEGSUP SWORK,SWORK2,MCHAML
  355.                   IRET=146
  356.                   MOTERR(1:8)='CHASUP  '
  357.                   GO TO 665
  358.                ENDIF
  359. *
  360.                N1PAUX=N1PTE1
  361. C
  362. C-----------------------------------------------------------------------
  363. C                     PETIT TEST POUR LE COQ4
  364. C       SI LE NOMBRE DE POINTS DE GAUSS VAUT 5 , ON NE PREND QUE
  365. C       LES 4 PREMIERS , LE 5-EME SERVANT UNIQUEMENT AU CISAILLEMENT
  366. C
  367.                IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4
  368. C-----------------------------------------------------------------------
  369. C
  370.             ELSE
  371.                N1PTEL=0
  372.                N1EL=0
  373.             ENDIF
  374. *
  375. *     ... Et dans le cas de variables complexes ...
  376. *
  377.             IF(TYPCHE(JCOMP)(1:8).EQ.'POINTEUR') THEN
  378.                N2PTE1=MELVA1.IELCHE(/1)
  379.                IF (N2PTE1.EQ.1) THEN
  380.                   N2PTEL=1
  381.                ELSE
  382.                   N2PTEL=NBPGAU
  383.                ENDIF
  384.                N2EL  =MELVA1.IELCHE(/2)
  385. *
  386. * ... Comme on ne sait pas extrapoler ou interpoler de variables
  387. *     composées, on n'en accepte qu'une par élément ...
  388.  
  389. *           IF(N2PTEL.NE.1) THEN
  390. *             SEGSUP SWORK,SWORK2,MCHAML
  391. *             IRET=755
  392. *             GO TO 665
  393. *           ENDIF
  394. *
  395. *  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
  396. *
  397.                IF(N2EL.NE.NEL.AND.N2EL.NE.1.AND.NEL.NE.1) THEN
  398.                   SEGSUP SWORK,SWORK2,MCHAML
  399.                   IRET=146
  400.                   MOTERR(1:8)='CHASUP  '
  401.                   GO TO 665
  402.                ENDIF
  403.  
  404.             ELSE
  405.                N2PTEL=0
  406.                N2EL=0
  407.             ENDIF
  408.             SEGINI MELVAL
  409.             IELVAL(JCOMP)=MELVAL
  410. *
  411. *  TRAITEMENT IMMEDIAT SI CHAMP CONSTANT
  412. *
  413. *         if(iplac1.eq.4) write(6,*)' n2ptel n1ptel',n2ptel,n1ptelq
  414.             IF(n2ptel.ne.0) then
  415.                IF(N2PTEL.EQ.1) THEN
  416.                   DO 4119 IEL=1,N2EL
  417.                      IELCHE(1,IEL)=MELVA1.IELCHE(1,IEL)
  418.  4119             CONTINUE
  419. C*        ELSE IF (N2PTEL.NE.1) THEN
  420.                ELSE
  421.                   IF (MINTE.NE.MINTE1. AND. IPLAC1.NE.IPLACA) THEN
  422.                      SEGSUP SWORK,SWORK2,MCHAML
  423.                      IRET=755
  424.                      GO TO 665
  425.                   ENDIF
  426.                   DO 4109 IGAU=1,N2PTEL
  427.                      DO 41091 IEL=1,N2EL
  428.                         IELCHE(IGAU,IEL)=MELVA1.IELCHE(IGAU,IEL)
  429. 41091                CONTINUE
  430.  4109             CONTINUE
  431.                ENDIF
  432.             else
  433.                IF(N1PTE1.EQ.1) THEN
  434.                   DO 4120 IEL=1,N1EL
  435.                      VELCHE(1,IEL)=MELVA1.VELCHE(1,IEL)
  436.  4120             CONTINUE
  437. *
  438.                ELSE
  439. *
  440. *          write (6,*) melva1.velche(/1),melva1.velche(/2)
  441.  
  442.                   DO 3120 IEL=1,NEL
  443.                      IF(IEL.GT.1.AND.N1EL.EQ.1) GO TO 3130
  444.                      DO 3121 IGAU=1,N1PTE1
  445.                         VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
  446.  3121                CONTINUE
  447.  
  448. *          write(6,*) 'MINTE1 = ',minte1
  449.  
  450. C
  451. C      1-ER CAS : LE CHAMELEM N'EST PAS AUX NOEUDS
  452. C
  453.                      IF(MINTE1.NE.0)THEN
  454. C
  455. C           MEME SUPPORT? ( attention test sur iplaca et iplac1 pour DKT)
  456. C
  457. *            write(6,*) ' meme support?',minte,minte1,iplac1,iplaca
  458.                         IF(MINTE.EQ.MINTE1. OR. IPLAC1.eq.IPLACA)
  459.      $                       THEN
  460.                            DO 3124 IGAU=1,N1PTE1
  461.                               VELCHE(IGAU,IEL)=VAL1(IGAU)
  462.  3124                      CONTINUE
  463. C
  464. C           SUPPORTS DIFFERENTS
  465. C
  466.                         ELSE
  467. C
  468. C   COQUE INTEGREE OU PAS ?
  469. C
  470.                            NPINT=INFMOD(1)
  471.                            IF (NPINT.NE.0.AND.NPINT.NE.1)THEN
  472.                               IRET = 19
  473.                               SEGSUP SWORK,SWORK2,MCHAML,MELVAL
  474.                               GO TO 665
  475.                            ENDIF
  476. C
  477.                            if (ieta.ne.1) then
  478.                               ieta=1
  479.                               segact mcoord
  480.                            endif
  481.                            CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  482.                            CALL QUEDIM(MELGEO,KERRE)
  483.                            CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL
  484.      $                          ,N1PAUX,NBNN,SWORK,IPOIN1,KERRE)
  485.                            IF(KERRE.NE.0) THEN
  486.                               IRET=KERRE
  487.                               SEGSUP SWORK,SWORK2,MCHAML,MELVAL
  488.                               GO TO 665
  489.                            ENDIF
  490. *
  491.                            DO 3122 IGAU=1,N1PTEL
  492.                               VELCHE(IGAU,IEL)=VAL2(IGAU)
  493.  3122                      CONTINUE
  494.                         ENDIF
  495. C
  496. C      2-EME CAS : LE CHAMELEM EST AUX NOEUDS
  497. C
  498.                      ELSE
  499. *
  500. *  AM  1/4/16 CAS PARTICULIER DES JOINTS
  501. *
  502.                         IF( MELGEO.EQ.12.OR.MELGEO.EQ.13
  503.      &                       .OR.MELGEO.EQ.29.OR.MELGEO.EQ.30
  504.      &                       .OR.MELGEO.EQ.31) THEN
  505. *
  506.                            IF(((IPLACA.EQ.0.OR.IPLACA.EQ.1).AND.
  507.      $                          IPLAC1.EQ.1).AND.(N1PTEL.EQ.N1PTE1))
  508.      $                          THEN
  509.                               DO IGAU=1,N1PTE1
  510.                                  VELCHE(IGAU,IEL)=VAL1(IGAU)
  511.                               ENDDO
  512.                            ELSE
  513. *
  514.                               IDECA=0
  515.                               IF(MELGEO.EQ.29) IDECA=2
  516.                               IF(MELGEO.EQ.30) IDECA=3
  517.                               IF(MELGEO.EQ.31) IDECA=4
  518.                               NBNOU=NBNN-IDECA
  519.                               NBNOV=SHPTOT(/2)-IDECA
  520. *
  521.                               MOCOMP=NOMCHE(JCOMP)
  522.                               IF (MOCOMP.EQ.'P  '.OR.
  523.      &                            MOCOMP.EQ.'PQ '.OR.
  524.      &                            MOCOMP.EQ.'TP '    ) THEN
  525.                                  DO IGAU=1,N1PTEL
  526.                                     VALG=0.D0
  527.                                     DO INO=1,IDECA
  528.                                        INO1 = NBNOU + INO
  529.                                        INO2 = NBNOV + INO
  530.                                        VALG=VALG+SHPTOT(1,INO2,IGAU)
  531.      $                                      *VAL1(INO1)
  532.                                     ENDDO
  533.                                     VELCHE(IGAU,IEL)=VALG
  534.                                  ENDDO
  535.  
  536.                               ELSE
  537.                                  DO IGAU=1,N1PTEL
  538.                                     VALG=0.D0
  539.                                     DO INO=1,NBNOU
  540.                                        VALG=VALG+SHPTOT(1,INO,IGAU)
  541.      $                                      *VAL1(INO)
  542.                                     ENDDO
  543.                                     VELCHE(IGAU,IEL)=VALG/2.D0
  544.                                  ENDDO
  545.                               ENDIF
  546.                            ENDIF
  547.  
  548.                         ELSE
  549.                            DO IGAU=1,N1PTEL
  550.                               VALG=0.D0
  551.                               DO INO=1,NBNN
  552.                                  VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO)
  553.                               ENDDO
  554.                               VELCHE(IGAU,IEL)=VALG
  555.                            ENDDO
  556.                         ENDIF
  557.  
  558.                      ENDIF
  559.  3120             CONTINUE
  560.  3130             CONTINUE
  561.  
  562.                ENDIF
  563.             endif
  564.  180     CONTINUE
  565.          SEGSUP SWORK,SWORK2
  566.  
  567.  100  CONTINUE
  568.       if (iresu.ne.nsous) then
  569.          n1=iresu
  570.          segadj mchelm
  571.       endif
  572.  
  573.  665  CONTINUE
  574. c      return
  575.       END
  576.  
  577.  
  578.  
  579.  

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