Télécharger la plaquette Cast3M


fr en

Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes : 

muchsc

  1. C MUCHSC    SOURCE    OF166741  25/02/21    21:18:04     12166          
  2.       SUBROUTINE MUCHSC(IPMODL,IPCHE1,IPCHE2,IPCHMU,LMOT1,LMOT2,LMOT3,
  3.      & IPLREE,IINV)
  4. *________________________________________________________________
  5. *
  6. *             MULTIPLICATION DE DEUX CHAMELEM
  7. *             --------------------------------
  8. *
  9. *  ENTREES :
  10. *  ---------
  11. *
  12. *     IPCHE1    POINTEUR SUR UN CHAMELEM
  13. *     IPCHE2    POINTEUR SUR UN CHAMELEM
  14. *     IPMODL    POINTEUR SUR UN MMODEL ; UTILISE SEULEMENT DANS LES CAS
  15. *               DES MULTIPLICATIONS :
  16. *                - ( HOOKE ou HOOTAN ) * ( CONTRAINTES ou DEFORMATIONS)
  17. *                - ( GRAD ou GRADFLEX ) * ( GRAD ou GRADFLEX )
  18. *               pour connaitre la formulation.
  19. *     IINV      +1 SI MULTIPLICATION ,  -1 SI DIVISION
  20. *     IPLREE   POINTEUR LISTREEL (PONDERATION COMPOSANTES RESULTATS)
  21. *
  22. *
  23. *  SORTIE :
  24. *  --------
  25. *
  26. *     IPCHMU    POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT
  27. *                DES DEUX PRECEDENTS.
  28. *               =0 SI L'OPERATION EST IMPOSSIBLE.
  29. *
  30. *  PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90
  31. *
  32. *________________________________________________________________
  33. *
  34.       IMPLICIT INTEGER(I-N)
  35.       IMPLICIT REAL*8(A-H,O-Z)
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39.  
  40. -INC SMCHAML
  41. -INC SMELEME
  42. -INC SMLREEL
  43. -INC SMCOORD
  44. -INC SMMODEL
  45. -INC SMLMOTS
  46.  
  47. -INC TMPTVAL
  48.  
  49.       SEGMENT MTRAA
  50.          INTEGER ITRAA(LX)
  51.       ENDSEGMENT
  52.  
  53.       SEGMENT INFO
  54.        INTEGER INFELL(JG)
  55.       ENDSEGMENT
  56.  
  57.       SEGMENT NOTYPE
  58.         CHARACTER*16 TYPE(NBTYPE)
  59.       ENDSEGMENT
  60.  
  61.       PARAMETER ( NINF=3 )
  62.       INTEGER INFOS(NINF)
  63.  
  64.       CHARACTER*(NCONCH) CONCH1,CONCH2,CONM
  65.       CHARACTER*72 TIT1,TIT2,TITC
  66.       LOGICAL lsupde,lsupre,lsupin,lsupco,lsupg1,lsupg2,lperm
  67.  
  68. *      write(ioimp,*) 'muchsc : lmot1,lmot2,lmot3,iplree=', lmot1,lmot2
  69. *     $     ,lmot3,iplree
  70.  
  71.       IPCHMU = 0
  72.       MLREE3 = 0
  73.  
  74.       ivagr1=0
  75.       ivagr2=0
  76.       ivares=0
  77.  
  78. *  si modele, on remet d'aplomb les chamelem
  79. *  Utile que si k = 4 ou 5 en sortie de CALPAQ !
  80.       IF (ipmodl.ne.0) then
  81.          ker = 0
  82.          ire = 0
  83.          call reduaf(ipche1,ipmodl,ipche10,0,ire,ker)
  84.          if (ire.ne.1) call erreur(ker)
  85.          if (ierr.NE.0) return
  86.          ipche1 = ipche10
  87.          call reduaf(ipche2,ipmodl,ipche20,0,ire,ker)
  88.          if (ierr.NE.0) return
  89.          if(ire.ne.1) call erreur(ker)
  90.          ipche2 = ipche20
  91.       ELSE
  92.          ipche10 = IPCHE1
  93.          ipche20 = IPCHE2
  94.       ENDIF
  95.  
  96.       MCHEL1 = IPCHE1
  97.       MCHEL2 = IPCHE2
  98.       SEGACT MCHEL1,MCHEL2
  99.  
  100. * Premieres verifications :
  101.       IFO1 = MCHEL1.IFOCHE
  102.       IFO2 = MCHEL2.IFOCHE
  103.       IF (IFO1.NE.IFO2) THEN
  104.         TIT1 = MCHEL1.TITCHE
  105.         TIT2 = MCHEL2.TITCHE
  106.         MOTERR(1: 8) = TIT1(1:8)
  107.         MOTERR(9:16) = TIT2(1:8)
  108.         CALL ERREUR(175)
  109.         GOTO 666
  110.       ENDIF
  111.       NSOUS1 = MCHEL1.ICHAML(/1)
  112.       NSOUS2 = MCHEL2.ICHAML(/1)
  113.       IF (NSOUS1.NE.NSOUS2) THEN
  114.         CALL ERREUR(103)
  115.         GOTO 666
  116.       ENDIF
  117. *
  118. *     SG 2018/01/16 si listmots donnes, on saute calpaq et on force le
  119. *     calcul composante par composante
  120. *      
  121.       if (lmot1.gt.0) then
  122.          K=3
  123.          TITC=' '
  124.          NUMCHA=1
  125.       else
  126.          CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET)
  127.          IF (IRET.EQ.0) GOTO 666
  128.       endif
  129. *      write(ioimp,*) 'muchsc : K=',K
  130. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  131.       lperm=(IPCHE1.ne.ipche10).or.(IPCHE2.ne.ipche20)
  132. *     Dans le cas de la division on sort si l ordre a change
  133.       IF (IINV.eq.-1) THEN
  134.          IF (lperm) THEN
  135.             write(ioimp,*)
  136.      $           'L ORDRE DES OPERANDES N A PAS PU ETRE CONSERVE'
  137.             write(ioimp,*) 'VERIFIEZ LE TYPE DES CHAMELEM'
  138.             MOTERR(1:8)=' /      '
  139.             call ERREUR(196)
  140.             GOTO 666
  141.          ENDIF
  142. *   CAS NON ADMIS POUR LA DIVISION
  143.          IF (K.EQ.4.OR.K.EQ.5) THEN
  144.             CALL ERREUR (21)
  145.             GOTO 666
  146.          ENDIF
  147.       ENDIF
  148. *     
  149.       MCHEL1 = IPCHE1
  150.       MCHEL2 = IPCHE2
  151. c*      SEGACT MCHEL1,MCHEL2  <- toujours ACTIFs
  152.       TIT1 = MCHEL1.TITCHE
  153.       TIT2 = MCHEL2.TITCHE
  154.       NSOUS1 = MCHEL1.ICHAML(/1)
  155.       NSOUS2 = MCHEL2.ICHAML(/1)
  156. *
  157. C Multiplication composante par composante :
  158.       IF (K.EQ.3) THEN
  159.          jgm1 = 0
  160. c noms de composante ?
  161.          IF (lmot1.gt.0) then
  162.             mlmot1 = lmot1
  163.             segact mlmot1
  164.             jgm1 = mlmot1.mots(/2)
  165.             mlmot2 = lmot2
  166.             segact mlmot2
  167.             jgm2 = mlmot2.mots(/2)
  168.             mlmot3 = lmot3
  169.             segact mlmot3
  170.             jgm3 = mlmot3.mots(/2)
  171.             if ((jgm1.ne.jgm2) .or. (jgm1.ne.jgm3)) then
  172.                MOTERR(1:8)='LISTMOTS'
  173.                MOTERR(9:16)='mots    '
  174.                call erreur(403)
  175.                goto 666
  176.             endif
  177.             if (IPLREE.gt.0) then
  178.                MLREE3 = IPLREE
  179.                segact mlree3
  180.                if (jgm1.ne.mlree3.prog(/1)) then
  181.                   MOTERR(1:8)='LIST****'
  182.                   MOTERR(9:16)='termes  '
  183.                   call erreur(403)
  184.                   goto 666
  185.                endif
  186.             endif
  187.          ENDIF
  188.       ENDIF
  189.  
  190.       IF (K.EQ.4.OR.K.EQ.5) THEN
  191.  
  192. *        BESOIN DU MMODEL
  193. *
  194.          IF (IPMODL.EQ.0) THEN
  195.             MOTERR(1:8)='MMODEL  '
  196.             CALL ERREUR (37)
  197.             GOTO 666
  198.          ENDIF
  199. *
  200. *        ACTIVATION DU MMODEL
  201. *
  202.          MMODEL=IPMODL
  203.          SEGACT MMODEL
  204.          NSOUMO=KMODEL(/1)
  205. *
  206. *        ON CREE UN CHAMELEM DE CONTRAINTE OU DE DEFORMATION ,
  207. *                            DE GRADIENT OU DE GRADIENT DE FLEXION.
  208. *
  209.          L1=NUMCHA
  210.          N1=NSOUMO
  211.          N3=MCHEL1.INFCHE(/2)
  212.          SEGINI MCHELM
  213.          IPCHMU=MCHELM
  214.          TITCHE=TITC
  215.          IFOCHE=IFO1
  216. *
  217. *        REMPLISSAGE DU CHAPEAU DU MCHAML
  218. *
  219.          isouss=0
  220.          DO 130 ISOUMO=1,NSOUMO
  221.             IMODEL=KMODEL(ISOUMO)
  222.             SEGACT IMODEL
  223.             IPMAIL=IMAMOD
  224.             CONM  =CONMOD
  225.             if((nefmod.eq.22).or.(nefmod.eq.259)) go to 134
  226.             isouss=isouss+1
  227.             DO 131 ISOUS1=1,NSOUS1
  228.                IPMAI1=MCHEL1.IMACHE(ISOUS1)
  229.                CONCH1=MCHEL1.CONCHE(ISOUS1)
  230.                IF (IPMAIL.EQ.IPMAI1. AND.CONM.EQ.CONCH1) THEN
  231.                   DO 132 N33=1,N3
  232.                      INFCHE(isouss,N33)=MCHEL1.INFCHE(ISOUS1,N33)
  233.  132              CONTINUE
  234.                   IMACHE(ISOUss)=IPMAI1
  235.                   CONCHE(ISOUss)=CONCH1
  236.                   GOTO 134
  237.                ENDIF
  238.  131        CONTINUE
  239. *
  240. *     ERREUR PAS DE CORRESPONDANCE
  241. *            
  242.             SEGSUP MCHELM
  243.             CALL ERREUR(103)
  244.             GOTO 666
  245.  134        CONTINUE
  246.  130     CONTINUE
  247.          if( nsoumo.ne.isouss)  then
  248.             n1=isouss
  249.             segadj mchelm
  250.             IPCHMU=mchelm
  251.          endif
  252.          nsous=isouss
  253. *
  254.       ELSE
  255. *
  256. *        QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2
  257. *
  258.          LX=NSOUS1
  259.          SEGINI MTRAA
  260.          DO 110 ISOUS1=1,NSOUS1
  261.             IPMAI1=MCHEL1.IMACHE(ISOUS1)
  262.             CONCH1=MCHEL1.CONCHE(ISOUS1)
  263.             DO 120 ISOUS2=1,NSOUS2
  264.                IPMAI2=MCHEL2.IMACHE(ISOUS2)
  265.                CONCH2=MCHEL2.CONCHE(ISOUS2)
  266.                IF(IPMAI1.NE.IPMAI2) GOTO 120
  267.                IF(CONCH1.NE.CONCH2) GOTO 120
  268.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  269.                IF (IRTD.EQ.0) GOTO 120
  270.                IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  271.                IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  272.                IF (IMINT1.EQ.IMINT2) GOTO 121
  273.                IMINT1= MCHEL1.INFCHE(ISOUS1,6)
  274.                IMINT2= MCHEL2.INFCHE(ISOUS2,6)
  275.                IF (IMINT1.EQ.IMINT2) GOTO 121
  276. *
  277. *              ERREUR PAS DE CORRESPONDANCE 2 A 2
  278. *
  279.                SEGSUP MTRAA
  280.                MOTERR(1: 8) = TIT1(1:8)
  281.                MOTERR(9:16) = TIT2(1:8)
  282.                CALL ERREUR (175)
  283.                GOTO 666
  284.  120        CONTINUE
  285. *
  286. *           PAS DE CORRESPONDANCE 2 A 2
  287. *on essaye betement de voir si maillage identique avec 2 pointeurs differents
  288. *
  289.             ipt1=ipmai1
  290.             segact ipt1
  291.             nbn1 = ipt1.num(/1)
  292.             nel1 = ipt1.num(/2)
  293.             DO 122 ISOUS2=1,NSOUS2
  294.                IPMAI2=MCHEL2.IMACHE(ISOUS2)
  295.                CONCH2=MCHEL2.CONCHE(ISOUS2)
  296.                IF (CONCH1.NE.CONCH2) GOTO 122
  297.                ipt2=ipmai2
  298.                segact ipt2
  299.                if(ipt1.itypel.ne.ipt2.itypel) then
  300.                   go to 122
  301.                endif
  302.                nel2=ipt2.num(/2)
  303.                if(nel1.ne.nel2) go to 122
  304.                do 123 lo=1,nel1
  305.                   do 1230 lp=1,nbn1
  306.                      if(ipt1.num(lp,lo).ne.ipt2.num(lp,lo) ) then
  307.                         go to 122
  308.                      endif
  309.  1230             continue
  310.  123           continue
  311.                IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  312.                IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  313.                IF (IMINT1.EQ.IMINT2) GOTO 121
  314.                IMINT1 = MCHEL1.INFCHE(ISOUS1,6)
  315.                IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
  316.                IF (IMINT1.EQ.IMINT2) GOTO 121
  317.  122        continue
  318.  
  319.             SEGSUP MTRAA
  320.             MOTERR(1:8)  = TIT1(1:8)
  321.             MOTERR(9:16) = TIT2(1:8)
  322.             CALL ERREUR (175)
  323.             GOTO 666
  324.  
  325.  121        CONTINUE
  326.             ITRAA(ISOUS1)=ISOUS2
  327.  110     CONTINUE
  328. *
  329. *        CREATION DU MCHELM RESULTAT
  330. *
  331.          NSOUS=NSOUS1
  332.          SEGINI,MCHELM=MCHEL1
  333.          IPCHMU=MCHELM
  334.       ENDIF
  335. *
  336. *________________________________________________________________
  337. *     BOUCLE  SUR LES SOUS PAQUETS DE MCHELM
  338. *
  339.       ISOUSS = 0
  340.  
  341.       DO 200 ISOUS=1,NSOUS
  342.  
  343.          ISOUSS = ISOUSS+1
  344. *
  345. ******** MULTIPLICATION SCALAIRE * SCALAIRE ********************
  346. *
  347.          IF (K.EQ.1) THEN
  348. *
  349.             ISOUS2=ITRAA(ISOUS)
  350.             MCHAM1=MCHEL1.ICHAML(ISOUS)
  351.             MCHAM2=MCHEL2.ICHAML(ISOUS2)
  352.             SEGACT MCHAM1,MCHAM2
  353.             IF (MCHAM1.TYPCHE(1).NE.'REAL*8'.OR.
  354.      &          MCHAM2.TYPCHE(1).NE.'REAL*8')  THEN
  355.                MOTERR(1:4)=MCHAM1.NOMCHE(1)(1:4)
  356.                CALL ERREUR (197)
  357.                GOTO 9999
  358.             ENDIF
  359.             MELVA1=MCHAM1.IELVAL(1)
  360.             MELVA2=MCHAM2.IELVAL(1)
  361.             SEGACT MELVA1,MELVA2
  362. *
  363. *           CREATION DU MCHAML DE LA SOUS ZONE
  364. *
  365.             N2=1
  366.             SEGINI MCHAML
  367.             NOMCHE(1)=MCHAM1.NOMCHE(1)
  368.             TYPCHE(1)='REAL*8'
  369.             ICHAML(ISOUS)=MCHAML
  370. *
  371.             N1GEL=MELVA1.VELCHE(/1)
  372.             N1BEL=MELVA1.VELCHE(/2)
  373.             N2GEL=MELVA2.VELCHE(/1)
  374.             N2BEL=MELVA2.VELCHE(/2)
  375. *
  376.             N1PTEL=MAX(N1GEL,N2GEL)
  377.             N1EL  =MAX(N1BEL,N2BEL)
  378.             N2PTEL=0
  379.             N2EL  =0
  380.             SEGINI MELVAL
  381.             IELVAL(1)=MELVAL
  382.             DO 1010 IGAU=1,N1PTEL
  383.                IGMN1=MIN(IGAU,N1GEL)
  384.                IGMN2=MIN(IGAU,N2GEL)
  385.                DO 10100 IB=1,N1EL
  386.                   IBMN1=MIN(IB  ,N1BEL)
  387.                   IBMN2=MIN(IB  ,N2BEL)
  388.                   XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  389.                   XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  390.                   IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2
  391.                   IF(IINV.EQ.-1)VELCHE(IGAU,IB)=XTT1/XTT2
  392. 10100          CONTINUE
  393.  1010       CONTINUE
  394.             GOTO 200
  395. *     
  396. ******** MULTIPLICATION COMPOSANTES * SCALAIRE *******************
  397. *
  398.          ELSE IF (K.EQ.2) THEN
  399. *
  400.             ISOUS2=ITRAA(ISOUS)
  401.             MCHAM1=MCHEL1.ICHAML(ISOUS)
  402.             MCHAM2=MCHEL2.ICHAML(ISOUS2)
  403.             SEGACT MCHAM1,MCHAM2
  404.             IF (MCHAM2.TYPCHE(1).NE.'REAL*8') THEN
  405. C               MOTERR(1:4)=MCHAM2.NOMCHE(1)(1:4)
  406.                CALL ERREUR (197)
  407.                GOTO 9999
  408.             ENDIF
  409.             MELVA2=MCHAM2.IELVAL(1)
  410.             SEGACT MELVA2
  411.             N2GEL=MELVA2.VELCHE(/1)
  412.             N2BEL=MELVA2.VELCHE(/2)
  413. *
  414. *           CREATION DU MCHAML DE LA SOUS ZONE
  415. *
  416.             SEGINI,MCHAML=MCHAM1
  417.             ICHAML(ISOUS)=MCHAML
  418.             DO 2010 ICOMP=1,IELVAL(/1)
  419.                MELVA1=IELVAL(ICOMP)
  420.                SEGACT MELVA1
  421.                N1GEL=MELVA1.VELCHE(/1)
  422.                IF (N1GEL.EQ.0) THEN
  423.                   N1GEL=MELVA1.IELCHE(/1)
  424.                   N1BEL=MELVA1.IELCHE(/2)
  425.                   N1PTEL=0
  426.                   N1EL=0
  427.                   N2PTEL=MAX(N1GEL,N2GEL)
  428.                   N2EL  =MAX(N1BEL,N2BEL)
  429.                   SEGINI MELVAL
  430.                   IELVAL(ICOMP)=MELVAL
  431.                   IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  432.                      DO 2020 IGAU=1,N2PTEL
  433.                         IGMN1=MIN(IGAU,N1GEL)
  434.                         IGMN2=MIN(IGAU,N2GEL)
  435.                         DO 20200 IB=1,N2EL
  436.                            IBMN1=MIN(IB  ,N1BEL)
  437.                            ILREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  438.                            IBMN2=MIN(IB  ,N2BEL)
  439.                            XTT1=MELVA2.VELCHE(IGMN2,IBMN2)
  440.                            CALL MUFLIR (ILREE1,XTT1,ILREEL,IINV)
  441.                            IELCHE(IGAU,IB)=ILREEL
  442. 20200                   CONTINUE
  443.  2020                CONTINUE
  444.                   ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT   ') THEN
  445.                      DO 2030 IGAU=1,N2PTEL
  446.                         IGMN1=MIN(IGAU,N1GEL)
  447.                         IGMN2=MIN(IGAU,N2GEL)
  448.                         DO 20300 IB=1,N2EL
  449.                            IBMN2=MIN(IB  ,N2BEL)
  450.                            XTT1=MELVA2.VELCHE(IGMN2,IBMN2)
  451.                            IBMN1=MIN(IB  ,N1BEL)
  452.                            IP=MELVA1.IELCHE(IGMN1,IBMN1)
  453.                            IREF=(IP-1)*(IDIM+1)
  454. *
  455. *                          ON CREE UN NVX POINTS :NOEUD NBNO+1
  456. *
  457.                            SEGACT MCOORD*mod
  458.                            NBNO=nbpts
  459.                            NBNOI=NBNO
  460.                            NBPTS=NBNO+1
  461.                            SEGADJ MCOORD
  462. *
  463.                            DO 2031 IC=1,IDIM
  464.            IF(IINV.EQ.1) XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XTT1
  465.            IF(IINV.EQ.-1)XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)/XTT1
  466.  2031                      CONTINUE
  467.                     XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
  468.                            IELCHE(IGAU,IB)=NBPTS
  469. 20300                   CONTINUE
  470.  2030                CONTINUE
  471.                   ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  472.                      DO 2040 IGAU=1,N2PTEL
  473.                         IGMN1=MIN(IGAU,N1GEL)
  474.                         IGMN2=MIN(IGAU,N2GEL)
  475.                         DO 20400 IB=1,N2EL
  476.                            IBMN1=MIN(IB  ,N1BEL)
  477.                            IEVOL1=MELVA1.IELCHE(IGMN1,IBMN1)
  478.                            IBMN2=MIN(IB  ,N2BEL)
  479.                            XTT1=MELVA2.VELCHE(IGMN2,IBMN2)
  480.                            CALL MUFLEV(IEVOL1,XTT1,IEVOL,IINV)
  481.                            IELCHE(IGAU,IB)=IEVOL
  482. 20400                   CONTINUE
  483.  2040                CONTINUE
  484.                   ELSE
  485. *
  486. *                    NOM DE COMPOSANTE NON RECONNU
  487. *
  488. C                     MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)(1:4)
  489.                      CALL ERREUR(197)
  490.                      SEGSUP MELVAL,MCHAML
  491.                      SEGSUP MCHELM,MTRAA,MCHAML
  492.                      GOTO 666
  493.                   ENDIF
  494.                ELSE
  495.                   N1BEL=MELVA1.VELCHE(/2)
  496.                   N1PTEL=MAX(N1GEL,N2GEL)
  497.                   N1EL  =MAX(N1BEL,N2BEL)
  498.                   N2PTEL=0
  499.                   N2EL=0
  500.                   SEGINI MELVAL
  501.                   IELVAL(ICOMP)=MELVAL
  502.                   DO 2050 IGAU=1,N1PTEL
  503.                      IGMN1=MIN(IGAU,N1GEL)
  504.                      IGMN2=MIN(IGAU,N2GEL)
  505.                      DO 20500 IB=1,N1EL
  506.                         IBMN1=MIN(IB  ,N1BEL)
  507.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  508.                         IBMN2=MIN(IB  ,N2BEL)
  509.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  510.                         IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2
  511.                         IF(IINV.EQ.-1)VELCHE(IGAU,IB)=XTT1/XTT2
  512. 20500                CONTINUE
  513.  2050             CONTINUE
  514.                ENDIF
  515.  2010       CONTINUE
  516.             GOTO 200
  517. *
  518. ******** MULTIPLICATION COMPOSANTE * COMPOSANTE *****************
  519. *
  520.          ELSE IF (K.EQ.3) THEN
  521. *
  522.             ISOUS2 = ITRAA(ISOUS)
  523.             MCHAM1 = MCHEL1.ICHAML(ISOUS)
  524.             MCHAM2 = MCHEL2.ICHAML(ISOUS2)
  525.             SEGACT,MCHAM1,MCHAM2
  526.             NCOMP1 = MCHAM1.IELVAL(/1)
  527.             NCOMP2 = MCHAM2.IELVAL(/1)
  528. *
  529. *           CREATION DU MCHAML DE LA SOUS ZONE
  530. *
  531.             IF (lmot1.GT.0) THEN
  532.                n2 = jgm1
  533.                SEGINI,MCHAML
  534.                NCOMP = jgm1
  535.             ELSE
  536.                SEGINI,MCHAML=MCHAM1
  537.                NCOMP = NCOMP1
  538.             ENDIF
  539.             ICHAML(ISOUS) = MCHAML
  540.  
  541.             DO 310 ICOMP = 1, NCOMP
  542.  
  543.               icomp2 = 0
  544.               IF (lmot1.GT.0) THEN
  545.                  icomp1 = 0
  546.                  CALL PLACE (MCHAM1.NOMCHE,NCOMP1, icomp1,
  547.      &                mlmot1.mots(icomp))
  548.                  IF (icomp1.EQ.0) THEN
  549.                     MOTERR(1:4) = mlmot1.mots(icomp)
  550.                     MOTERR(5:40) = 'MCHAML1'
  551.                     CALL ERREUR(77)
  552.                     SEGSUP MCHAML,MCHELM,MTRAA
  553.                     GOTO 666
  554.                  ENDIF
  555.                  MOTERR(1:4) = mlmot2.mots(icomp)
  556.                  CALL PLACE (MCHAM2.NOMCHE,NCOMP2, icomp2,
  557.      &                mlmot2.mots(icomp))
  558.                  nomche(icomp) = mlmot3.mots(icomp)
  559.               ELSE
  560.                  icomp1 = icomp
  561.                  MOTERR(1:4) = mcham1.nomche(icomp1)
  562.                  CALL PLACE (MCHAM2.NOMCHE,NCOMP2,icomp2,
  563.      &                MCHAM1.NOMCHE(icomp1))
  564. **                nomche(icomp) = MCHAM1.NOMCHE(icomp1)
  565.               ENDIF
  566.               IF (icomp2.EQ.0) THEN
  567.                 MOTERR(5:40)='MCHAML2'
  568.                 CALL ERREUR(77)
  569.                 SEGSUP MCHAML,MCHELM,MTRAA
  570.                 GOTO 666
  571.               ENDIF
  572.  
  573.               MELVA1 = MCHAM1.IELVAL(icomp1)
  574.               MELVA2 = MCHAM2.IELVAL(icomp2)
  575.               SEGACT,MELVA1,MELVA2
  576.               IF (MCHAM1.TYPCHE(icomp1).EQ.'REAL*8' .AND.
  577.      &            MCHAM2.TYPCHE(icomp2).EQ.'REAL*8') THEN
  578.                 N1GEL = MELVA1.VELCHE(/1)
  579.                 N1BEL = MELVA1.VELCHE(/2)
  580.                 N2GEL = MELVA2.VELCHE(/1)
  581.                 N2BEL = MELVA2.VELCHE(/2)
  582.                 N1PTEL = MAX(N1GEL,N2GEL)
  583.                 N1EL   = MAX(N1BEL,N2BEL)
  584.                 N2PTEL = 0
  585.                 N2EL   = 0
  586.                 SEGINI,MELVAL
  587.                 TYPCHE(icomp) = 'REAL*8          '
  588.                 IELVAL(icomp) = MELVAL
  589. *
  590.                 DO 320 IGAU=1,N1PTEL
  591.                    IGMN1=MIN(IGAU,N1GEL)
  592.                    IGMN2=MIN(IGAU,N2GEL)
  593.                    DO 321 IB=1,N1EL
  594.                       IBMN1=MIN(IB  ,N1BEL)
  595.                       IBMN2=MIN(IB  ,N2BEL)
  596.                       XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  597.                       XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  598.                       IF(IINV.EQ.1)  XVAL=XTT1*XTT2
  599.                       IF(IINV.EQ.-1) XVAL=XTT1/XTT2
  600.                       if (MLREE3.ne.0) xval=xval*mlree3.prog(icomp)
  601.                       VELCHE(IGAU,IB)=XVAL
  602.  321               CONTINUE
  603.  320            CONTINUE
  604.              ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'REAL*8' .AND.
  605.      &                MCHAM2.TYPCHE(icomp2).EQ.'POINTEURLISTREEL') THEN
  606.                 N1GEL = MELVA1.VELCHE(/1)
  607.                 N1BEL = MELVA1.VELCHE(/2)
  608.                 N2GEL = MELVA2.IELCHE(/1)
  609.                 N2BEL = MELVA2.IELCHE(/2)
  610.                 N1PTEL = 0
  611.                 N1EL   = 0
  612.                 N2PTEL = MAX(N1GEL,N2GEL)
  613.                 N2EL   = MAX(N1BEL,N2BEL)
  614.                 SEGINI MELVAL
  615.  
  616.                 TYPCHE(icomp) = 'POINTEURLISTREEL'
  617.                 IELVAL(icomp) = MELVAL
  618.  
  619.                 DO 331 IGAU=1,N2PTEL
  620.                    IGMN1=MIN(IGAU,N1GEL)
  621.                    IGMN2=MIN(IGAU,N2GEL)
  622.                    DO 3310 IB=1,N2EL
  623.                       IBMN1=MIN(IB  ,N1BEL)
  624.                       IBMN2=MIN(IB  ,N2BEL)
  625.                       xtt1 = melva1.velche(igmn1,ibmn1)
  626.                       MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  627.                       SEGACT MLREE2
  628.                       IPROG2=MLREE2.PROG(/1)
  629.                       JG= IPROG2
  630.                       SEGINI MLREEL
  631.                       DO 341 IPROG=1,JG
  632.                          IF(IINV.EQ.1)  XVAL=xtt1*MLREE2.PROG(IPROG)
  633.                          IF(IINV.EQ.-1) XVAL=xtt1/MLREE2.PROG(IPROG)
  634.                          if (MLREE3.gt.0) xval=xval*mlree3.prog(icomp)
  635.                          PROG(IPROG)=xval
  636.  341                  CONTINUE
  637.                       IELCHE(IGAU,IB)=MLREEL
  638.  3310              CONTINUE
  639.  331            CONTINUE
  640.              ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEURLISTREEL' .AND.
  641.      &                MCHAM2.TYPCHE(icomp2).EQ.'REAL*8') THEN
  642.                 N1GEL=MELVA1.IELCHE(/1)
  643.                 N1BEL=MELVA1.IELCHE(/2)
  644.                 N2GEL=MELVA2.VELCHE(/1)
  645.                 N2BEL=MELVA2.VELCHE(/2)
  646.                 N1PTEL=0
  647.                 N1EL=0
  648.                 N2PTEL=MAX(N1GEL,N2GEL)
  649.                 N2EL  =MAX(N1BEL,N2BEL)
  650.                 SEGINI MELVAL
  651.                 IELVAL(icomp)=MELVAL
  652.                 TYPCHE(icomp) = 'POINTEURLISTREEL'
  653.                 DO 332 IGAU=1,N2PTEL
  654.                    IGMN1=MIN(IGAU,N1GEL)
  655.                    IGMN2=MIN(IGAU,N2GEL)
  656.                    DO 3320 IB=1,N2EL
  657.                       IBMN1=MIN(IB  ,N1BEL)
  658.                       IBMN2=MIN(IB  ,N2BEL)
  659.                       xtt2 = melva2.velche(igmn2,ibmn2)
  660.                       MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  661.                       SEGACT MLREE1
  662.                       IPROG1=MLREE1.PROG(/1)
  663.                       JG= IPROG1
  664.                       SEGINI MLREEL
  665.                       DO 342 IPROG=1,JG
  666.                          IF(IINV.EQ.1)  xval=xtt2*MLREE1.PROG(IPROG)
  667.                          IF(IINV.EQ.-1) xval=xtt2/MLREE1.PROG(IPROG)
  668.                          if (MLREE3.gt.0) xval=xval*mlree3.prog(icomp)
  669.                          PROG(IPROG)=xval
  670.  342                  CONTINUE
  671.                       IELCHE(IGAU,IB)=MLREEL
  672.  3320              CONTINUE
  673.  332            CONTINUE
  674.              ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEURLISTREEL' .AND.
  675.      &                MCHAM2.TYPCHE(icomp2).EQ.'POINTEURLISTREEL') THEN
  676.                 N1GEL=MELVA1.IELCHE(/1)
  677.                 N1BEL=MELVA1.IELCHE(/2)
  678.                 N2GEL=MELVA2.IELCHE(/1)
  679.                 N2BEL=MELVA2.IELCHE(/2)
  680.                 N1PTEL=0
  681.                 N1EL=0
  682.                 N2PTEL=MAX(N1GEL,N2GEL)
  683.                 N2EL  =MAX(N1BEL,N2BEL)
  684.                 SEGINI MELVAL
  685.                 IELVAL(icomp)=MELVAL
  686.                 TYPCHE(icomp) = 'POINTEURLISTREEL'
  687.  
  688.                 DO 330 IGAU=1,N2PTEL
  689.                    IGMN1=MIN(IGAU,N1GEL)
  690.                    IGMN2=MIN(IGAU,N2GEL)
  691.                    DO 3300 IB=1,N2EL
  692.                       IBMN1=MIN(IB  ,N1BEL)
  693.                       IBMN2=MIN(IB  ,N2BEL)
  694.                       MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  695.                       MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  696.                       SEGACT MLREE1,MLREE2
  697.                       IPROG1=MLREE1.PROG(/1)
  698.                       IPROG2=MLREE2.PROG(/1)
  699.                       JG=MAX(IPROG1,IPROG2)
  700.                       SEGINI MLREEL
  701.                       DO 340 IPROG=1,JG
  702.                          IF ( (IPROG.GT.IPROG1).OR.
  703.      &                        (IPROG.GT.IPROG2) ) THEN
  704.                             PROG(IPROG)=0.D0
  705.                          ELSE
  706.                             IF(IINV.EQ.1)  xval=MLREE1.PROG(IPROG)
  707.      $                           *MLREE2.PROG(IPROG)
  708.                             IF(IINV.EQ.-1) xval=MLREE1.PROG(IPROG)
  709.      &                           /MLREE2.PROG(IPROG)
  710.                             if (MLREE3.gt.0) xval=xval
  711.      $                           *mlree3.prog(icomp)
  712.                             PROG(IPROG)=XVAL
  713.                          ENDIF
  714.  340                  CONTINUE
  715.                       IELCHE(IGAU,IB)=MLREEL
  716.  3300              CONTINUE
  717.  330            CONTINUE
  718.              ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEUREVOLUTIO' .AND.
  719.      &                MCHAM2.TYPCHE(icomp2).EQ.'POINTEUREVOLUTIO') THEN
  720.                 N1GEL=MELVA1.IELCHE(/1)
  721.                 N1BEL=MELVA1.IELCHE(/2)
  722.                 N2GEL=MELVA2.IELCHE(/1)
  723.                 N2BEL=MELVA2.IELCHE(/2)
  724.                 N1PTEL=0
  725.                 N1EL=0
  726.                 N2PTEL=MAX(N1GEL,N2GEL)
  727.                 N2EL  =MAX(N1BEL,N2BEL)
  728.                 SEGINI MELVAL
  729.  
  730.                 IELVAL(ICOMP)=MELVAL
  731.                 TYPCHE(ICOMP) = 'POINTEUREVOLUTIO'
  732.  
  733.                 DO 333 IGAU=1,N2PTEL
  734.                    IGMN1=MIN(IGAU,N1GEL)
  735.                    IGMN2=MIN(IGAU,N2GEL)
  736.                    DO 3330 IB=1,N2EL
  737.                       IBMN1=MIN(IB,N1BEL)
  738.                       IBMN2=MIN(IB,N2BEL)
  739.                       MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1)
  740.                       MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2)
  741.                       CALL PUIS(MEVOL1,MEVOL2,MEVOL3,IINV)
  742.                       IF (MLREE3.GT.0) THEN
  743.                          XFLOT1=MLREE3.prog(ICOMP)
  744.                          CALL MUFLEV(MEVOL3,XFLOT1,MEVOL3,1)
  745.                       ENDIF
  746.                       IELCHE(IGAU,IB)=MEVOL3
  747.  3330              CONTINUE
  748.  333            CONTINUE
  749.              ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'REAL*8' .AND.
  750.      &                MCHAM2.TYPCHE(icomp2).EQ.'POINTEUREVOLUTIO') THEN
  751.                 N1GEL=MELVA1.VELCHE(/1)
  752.                 N1BEL=MELVA1.VELCHE(/2)
  753.                 N2GEL=MELVA2.IELCHE(/1)
  754.                 N2BEL=MELVA2.IELCHE(/2)
  755.                 N1PTEL=0
  756.                 N1EL=0
  757.                 N2PTEL=MAX(N1GEL,N2GEL)
  758.                 N2EL  =MAX(N1BEL,N2BEL)
  759.                 SEGINI MELVAL
  760.  
  761.                 IELVAL(ICOMP)=MELVAL
  762.                 TYPCHE(ICOMP) = 'POINTEUREVOLUTIO'
  763.  
  764.                 DO 334 IGAU=1,N2PTEL
  765.                    IGMN1=MIN(IGAU,N1GEL)
  766.                    IGMN2=MIN(IGAU,N2GEL)
  767.                    DO 3340 IB=1,N2EL
  768.                       IBMN1=MIN(IB,N1BEL)
  769.                       IBMN2=MIN(IB,N2BEL)
  770.                       XFLOT1=MELVA1.VELCHE(IGMN1,IBMN1)
  771.                       MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2)
  772.                       IF (MLREE3.GT.0) THEN
  773.                          XFLOT1=XFLOT1*MLREE3.prog(ICOMP)
  774.                       ENDIF
  775.                       CALL MUFLEV(MEVOL2,XFLOT1,IRET,IINV)
  776.                       IELCHE(IGAU,IB)=IRET
  777.  3340              CONTINUE
  778.  334            CONTINUE
  779.              ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEUREVOLUTIO' .AND.
  780.      &                MCHAM2.TYPCHE(icomp2).EQ.'REAL*8') THEN
  781.                 N1GEL=MELVA1.IELCHE(/1)
  782.                 N1BEL=MELVA1.IELCHE(/2)
  783.                 N2GEL=MELVA2.VELCHE(/1)
  784.                 N2BEL=MELVA2.VELCHE(/2)
  785.                 N1PTEL=0
  786.                 N1EL=0
  787.                 N2PTEL=MAX(N1GEL,N2GEL)
  788.                 N2EL  =MAX(N1BEL,N2BEL)
  789.                 SEGINI MELVAL
  790.  
  791.                 IELVAL(ICOMP) = MELVAL
  792.                 TYPCHE(ICOMP) = 'POINTEUREVOLUTIO'
  793.  
  794.                 DO 335 IGAU=1,N2PTEL
  795.                    IGMN1=MIN(IGAU,N1GEL)
  796.                    IGMN2=MIN(IGAU,N2GEL)
  797.                    DO 3350 IB=1,N2EL
  798.                       IBMN1=MIN(IB,N1BEL)
  799.                       IBMN2=MIN(IB,N2BEL)
  800.                       MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1)
  801.                       XFLOT1=MELVA2.VELCHE(IGMN2,IBMN2)
  802.                       IF (MLREE3.GT.0) THEN
  803.                          XFLOT1=XFLOT1*MLREE3.prog(ICOMP)
  804.                       ENDIF
  805.                       CALL MUFLEV(MEVOL1,XFLOT1,IRET,IINV)
  806.                       IELCHE(IGAU,IB)=IRET
  807.  3350              CONTINUE
  808.  335            CONTINUE
  809. *
  810. *                 NOM DE COMPOSANTE NON RECONNU
  811. *
  812.              ELSE
  813.                 MOTERR(1:4)='*   '
  814. C                  MOTERR(5:8)=NOMCHE(ICOMP)(1:4)
  815.                 CALL ERREUR(335)
  816.                 SEGSUP MCHAML,MCHELM,MTRAA
  817.                 GOTO 666
  818.              ENDIF
  819.  310      CONTINUE
  820.           GOTO 200
  821.  
  822. *
  823. ******** MULTIPLICATION MATRICE * COMPOSANTE ******************
  824. *
  825.        ELSE IF (K.EQ.4) THEN
  826. *
  827.           IMODEL=KMODEL(ISOUS)
  828.           SEGACT IMODEL
  829.           IPMAIL=IMAMOD
  830.           CONM  =CONMOD
  831.           MELE=NEFMOD
  832. C
  833. C   COQUE INTEGREE OU PAS ?
  834. C
  835.           NPINT=INFMOD(1)
  836.           IF (NPINT.NE.0)THEN
  837.              CALL ERREUR(615)
  838.              SEGSUP MCHELM
  839.              GOTO 666
  840.           ENDIF
  841. *
  842. *           INFORMATION SUR L'ELEMENT FINI
  843. *
  844.           CALL ELQUOI (MELE,0,6,IPINF,IMODEL)
  845.           IF (IERR.NE.0) THEN
  846.              SEGSUP MCHELM
  847.              GOTO 666
  848.           ENDIF
  849.           INFO=IPINF
  850.           MFR=INFELL(13)
  851.           segsup info
  852. *
  853. *           CREATION DU TABLEAU INFOS
  854. *
  855.           lsupin=.true.
  856.           lsupre=.true.
  857.           CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  858.           if(lnomid(5).ne.0) then
  859.              nomid=lnomid(5)
  860.              segact nomid
  861.              nobde=lesobl(/2)
  862.              lsupde=.false.
  863.              modef=nomid
  864.           else
  865.              lsupde=.true.
  866.              CALL IDDEFO (IMODEL,IFO1,MOdef ,Nobde ,NFAC)
  867.           endif
  868.           if(lnomid(4).ne.0) then
  869.              nomid=lnomid(4)
  870.              segact nomid
  871.              mocon=nomid
  872.              nconn=lesobl(/2)
  873.              nfac=lesfac(/2)
  874.              lsupco=.false.
  875.           else
  876.              lsupco=.true.
  877.              CALL IDCONT (IMODEL,IFO1,MOCOn,NCOnn ,NFAC)
  878.           endif
  879.           IF (NUMCHA.EQ.12) THEN
  880.              mocomp=mocon
  881.              ncom=nconn
  882.              lsupin=lsupco
  883.              mores=modef
  884.              nres= nobde
  885.              lsupre=lsupde
  886.           ELSE
  887.              mores=mocon
  888.              nres=nconn
  889.              lsupre=lsupco
  890.              mocomp=modef
  891.              ncom=nobde
  892.              lsupin=lsupde
  893.           ENDIF
  894. *
  895. *           VERIFICATION DE LA PRESENCE DES COMPOSANTES
  896. *
  897. *
  898.           NBTYPE=1
  899.           SEGINI NOTYPE
  900.           MOTYPE=NOTYPE
  901.           TYPE(1)='REAL*8'
  902.           CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
  903.      1         MOTYPE,1,INFOS,3,IVACOM)
  904.           SEGSUP NOTYPE
  905.           IF (IERR.NE.0) GOTO 4998
  906. *
  907. *           VERIFICATION PRESENCE DE LA MATRICE DE HOOKE
  908. *
  909.           NBROBL=1
  910.           NBRFAC=0
  911.           SEGINI NOMID
  912.           MOHOOK=NOMID
  913.           LESOBL(1)='MAHO'
  914. *
  915. *           VERIFICATION DE LA PRESENCE DES COMPOSANTES
  916. *
  917.           NBTYPE=1
  918.           SEGINI NOTYPE
  919.           MOTYPE=NOTYPE
  920.           TYPE(1)='POINTEURLISTREEL'
  921.           CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOHOOK,
  922.      1         MOTYPE,1,INFOS,3,IVAHOO)
  923.           SEGSUP NOTYPE
  924.           IF (IERR.NE.0) GOTO 4999
  925. *
  926. *           RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  927. *
  928.           MPTVAL=IVAHOO
  929.           MELVAL=IVAL(1)
  930.           N1PTEL=IELCHE(/1)
  931.           N1EL  =IELCHE(/2)
  932.           MPTVAL=IVACOM
  933.           DO 401 IO=1,NCOM
  934.              MELVAL=IVAL(IO)
  935.              N1PTEL=MAX(N1PTEL,VELCHE(/1))
  936.              N1EL  =MAX(N1EL  ,VELCHE(/2))
  937.  401      CONTINUE
  938. *
  939. *           CREATION DU MCHAML DE LA SOUS ZONE
  940. *
  941.           N2=NRES
  942.           SEGINI MCHAML
  943.           ICHAML(ISOUS)=MCHAML
  944.           NSR=1
  945.           NCOSOR=NRES
  946.           SEGINI MPTVAL
  947.           IVARES=MPTVAL
  948.           NOMID=MORES
  949.           SEGACT NOMID
  950.           DO 402 ICOMP=1,NRES
  951.              NOMCHE(ICOMP)=LESOBL(ICOMP)
  952.              TYPCHE(ICOMP)='REAL*8'
  953.              N2PTEL=0
  954.              N2EL=0
  955.              SEGINI MELVAL
  956.              IELVAL(ICOMP)=MELVAL
  957.              IVAL(ICOMP)=MELVAL
  958.  402      CONTINUE
  959.           DO 403 IGAU=1,N1PTEL
  960.              DO 4030 IB=1,N1EL
  961.                 MPTVAL=IVAHOO
  962.                 MELVAL=IVAL(1)
  963.                 IBMN=MIN(IB  ,IELCHE(/2))
  964.                 IGMN=MIN(IGAU,IELCHE(/1))
  965.                 MLREEL=IELCHE(IGMN,IBMN)
  966.                 SEGACT MLREEL
  967. *
  968. *                 traitement special pour poreux ( mfr=33 )
  969. *
  970.                 NCOMM = NCOM
  971.                 IF(MFR.EQ.33) NCOMM=NCOM-1
  972. *
  973.                 DO 404 ID=1,NCOMM
  974.                    CC=0.D0
  975.                    JJ = ID
  976.                    MPTVAL=IVACOM
  977.                    DO 405 JA=1,NCOMM
  978.                       MELVAL=IVAL(JA)
  979.                       IGMN=MIN(IGAU,VELCHE(/1))
  980.                       IBMN=MIN(IB  ,VELCHE(/2))
  981.                       XTT1 =VELCHE(IGMN,IBMN)
  982.                       IF (JJ.GT.PROG(/1)) THEN
  983.                          XTT2=0.D0
  984.                       ELSE
  985.                          XTT2 =PROG(JJ)
  986.                       ENDIF
  987.                       CC = CC + XTT1 * XTT2
  988.                       JJ = JJ + NCOMM
  989.  405               CONTINUE
  990.                    IF (ID.LE.NRES) THEN
  991. *
  992. *                       CAS MFR=17
  993. *
  994.                       MPTVAL=IVARES
  995.                       MELVAL=IVAL(ID)
  996.                       VELCHE(IGAU,IB)=CC
  997.                    ENDIF
  998.  404            CONTINUE
  999.                 IF(MFR.EQ.33) THEN
  1000.                    MPTVAL=IVACOM
  1001.                    MELVAL=IVAL(NCOM)
  1002.                    IGMN=MIN(IGAU,VELCHE(/1))
  1003.                    IBMN=MIN(IB  ,VELCHE(/2))
  1004.                    CC =VELCHE(IGMN,IBMN)
  1005.                    MPTVAL=IVARES
  1006.                    MELVAL=IVAL(NRES)
  1007.                    VELCHE(IGAU,IB)=CC
  1008.                 ENDIF
  1009.  4030        CONTINUE
  1010.  403      CONTINUE
  1011. *
  1012.           CALL DTMVAL(IVACOM,1)
  1013. *
  1014.           CALL DTMVAL(IVAHOO,1)
  1015. *
  1016.           CALL DTMVAL(IVARES,1)
  1017. *
  1018.           NOMID=MOCOMP
  1019.           if(lsupin)SEGSUP NOMID
  1020.           NOMID=MOHOOK
  1021.           SEGSUP NOMID
  1022.           NOMID=MORES
  1023.           if(lsupre)SEGSUP NOMID
  1024. *
  1025. *            SEGSUP INFO
  1026.           GOTO 200
  1027. *
  1028. *           ERREUR DESACTIVATION ET RETOUR
  1029. *
  1030.  4999     CONTINUE
  1031. *
  1032.           CALL DTMVAL(IVAHOO,1)
  1033.           NOMID=MOHOOK
  1034.           SEGSUP NOMID
  1035. *
  1036.  4998     CONTINUE
  1037.           CALL DTMVAL(IVACOM,1)
  1038.           NOMID=MOCOMP
  1039.           if(lsupin)SEGSUP NOMID
  1040.           NOMID=MORES
  1041.           if(lsupre)SEGSUP NOMID
  1042. *
  1043. *            SEGSUP INFO
  1044.           SEGSUP MCHELM
  1045.           IPCHMU=0
  1046.           RETURN
  1047.  
  1048. *
  1049. ******** MULTIPLICATION GRADIENT * GRADIENT ********************
  1050. *
  1051.        ELSE IF (K.EQ.5) THEN
  1052. *
  1053.  4997       CONTINUE            
  1054.             IMODEL=KMODEL(ISOUSS)
  1055.             SEGACT IMODEL
  1056.             IPMAIL=IMAMOD
  1057.             CONM  =CONMOD
  1058.             MELE=NEFMOD
  1059.             IF ((MELE.EQ.259).OR.(MELE.EQ.22)) THEN
  1060.                 ISOUSS = ISOUSS+1
  1061.                 goto 4997
  1062.             ENDIF
  1063.  
  1064. *
  1065. *           INFORMATION SUR L'ELEMENT FINI
  1066. *
  1067.           CALL ELQUOI (MELE,0,6,IPINF,IMODEL)
  1068.           IF (IERR.NE.0) THEN
  1069.              SEGSUP MCHELM
  1070.              IPCHMU=0
  1071.              RETURN
  1072.           ENDIF
  1073.           INFO=IPINF
  1074.           MFR=INFELL(13)
  1075.           segsup info
  1076. *
  1077. *           CREATION DU TABLEAU INFOS
  1078. *
  1079.           CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  1080. *
  1081.           lsupg1=.true.
  1082.           IF (TIT1.EQ.'GRADIENT') THEN
  1083.              if(lnomid(3).ne.0) then
  1084.                 nomid=lnomid(3)
  1085.                 segact nomid
  1086.                 mogra1=nomid
  1087.                 ngra1=lesobl(/2)
  1088.                 nfac=lesfac(/2)
  1089.                 lsupg1=.false.
  1090.              else
  1091.                 CALL IDGRAD (MFR,IFO1,MOGRA1,NGRA1,NFAC)
  1092.              endif
  1093.           ELSE IF (TIT1.EQ.'GRADIENT DE FLEXION') THEN
  1094.              if(lnomid(11).ne.0) then
  1095.                 nomid=lnomid(11)
  1096.                 segact nomid
  1097.                 mogra1=nomid
  1098.                 ngra1=lesobl(/2)
  1099.                 nfac=lesfac(/2)
  1100.                 lsupg1=.false.
  1101.              else
  1102.                 CALL IDGRAF (MFR,IFO1,MOGRA1,NGRA1,NFAC)
  1103.              endif
  1104.           ELSE
  1105.              CALL ERREUR (21)
  1106.              SEGSUP MCHELM
  1107.              IPCHMU=0
  1108.              RETURN
  1109.           ENDIF
  1110. *
  1111.           lsupg2=.true.
  1112.           IF (TIT2.EQ.'GRADIENT DE FLEXION') THEN
  1113.              if(lnomid(11).ne.0) then
  1114.                 nomid=lnomid(11)
  1115.                 segact nomid
  1116.                 mogra2=nomid
  1117.                 ngra2=lesobl(/2)
  1118.                 nfac=lesfac(/2)
  1119.                 lsupg2=.false.
  1120.              else
  1121.                 CALL IDGRAF (MFR,IFO2,MOGRA2,NGRA2,NFAC)
  1122.              endif
  1123.           ELSE IF (TIT2.EQ.'GRADIENT') THEN
  1124.              if(lnomid(3).ne.0) then
  1125.                 nomid=lnomid(3)
  1126.                 segact nomid
  1127.                 mogra2=nomid
  1128.                 ngra2=lesobl(/2)
  1129.                 nfac=lesfac(/2)
  1130.                 lsupg2=.false.
  1131.              else
  1132.                 CALL IDGRAD (MFR,IFO2,MOGRA2,NGRA2,NFAC)
  1133.              endif
  1134.           ELSE
  1135.              CALL ERREUR (21)
  1136.              SEGSUP MCHELM
  1137.              NOMID=MOGRA1
  1138.              if(lsupg1)SEGSUP NOMID
  1139.              IPCHMU=0
  1140.              RETURN
  1141.           ENDIF
  1142. *
  1143.           NBTYPE=1
  1144.           SEGINI NOTYPE
  1145.           MOTYPE=NOTYPE
  1146.           TYPE(1)='REAL*8'
  1147.           CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRA1,MOTYPE,
  1148.      1         1,INFOS,3,IVAGR1)
  1149.           SEGSUP NOTYPE
  1150.           IF (IERR.NE.0) GOTO 5998
  1151. *
  1152.           NBTYPE=1
  1153.           SEGINI NOTYPE
  1154.           MOTYPE=NOTYPE
  1155.           TYPE(1)='REAL*8'
  1156.           CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRA2,
  1157.      1         MOTYPE,1,INFOS,3,IVAGR2)
  1158.           SEGSUP NOTYPE
  1159.           IF (IERR.NE.0) GOTO 5999
  1160. *
  1161. *           RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  1162. *
  1163.           N1PTEL=0
  1164.           N1EL=0
  1165.           MPTVAL=IVAGR1
  1166.           DO 520 IO=1,NGRA1
  1167.              MELVAL=IVAL(IO)
  1168.              N1PTEL=MAX(N1PTEL,VELCHE(/1))
  1169.              N1EL  =MAX(N1EL  ,VELCHE(/2))
  1170.  520      CONTINUE
  1171. *
  1172. *           CREATION DU MCHAML DE LA SOUS ZONE
  1173. *
  1174.           N2=NGRA1
  1175.           SEGINI MCHAML
  1176.           ICHAML(ISOUS)=MCHAML
  1177.           NSR=1
  1178.           NCOSOR=NGRA1
  1179.           SEGINI MPTVAL
  1180.           IVARES=MPTVAL
  1181.           NOMID=MOGRA1
  1182.           SEGACT NOMID
  1183.           DO 521 ICOMP=1,NGRA1
  1184.              NOMCHE(ICOMP)=LESOBL(ICOMP)
  1185.              TYPCHE(ICOMP)='REAL*8'
  1186.              N2PTEL=0
  1187.              N2EL=0
  1188.              SEGINI MELVAL
  1189.              IELVAL(ICOMP)=MELVAL
  1190.              IVAL(ICOMP)=MELVAL
  1191.  521      CONTINUE
  1192. *
  1193.           NBPTEL=N1PTEL
  1194.           NEL   =N1EL
  1195. *
  1196.           DO 502 IGAU=1,NBPTEL
  1197.              DO 5020 IB=1,NEL
  1198. C Gradient d'un champ scalaire (1, 2 ou 3 composantes en fct. de IDIM)
  1199.                 IF (NGRA1.EQ.IDIM) THEN
  1200. C                 1e composante
  1201.                    MPTVAL=IVAGR1
  1202.                    MELVAL=IVAL(1)
  1203.                    IGMN1=MIN(IGAU,VELCHE(/1))
  1204.                    IBMN1=MIN(IB  ,VELCHE(/2))
  1205.                    XTT1=VELCHE(IGMN1,IBMN1)
  1206.                    MPTVAL=IVAGR2
  1207.                    MELVAL=IVAL(1)
  1208.                    IGMN2=MIN(IGAU,VELCHE(/1))
  1209.                    IBMN2=MIN(IB  ,VELCHE(/2))
  1210.                    XTT2=VELCHE(IGMN2,IBMN2)
  1211.                    MPTVAL=IVARES
  1212.                    MELVAL=IVAL(1)
  1213.                    VELCHE(IGAU,IB)=XTT1*XTT2
  1214.                    IF (NGRA1.GT.1) THEN
  1215. C                 2e composante
  1216.                       MPTVAL=IVAGR1
  1217.                       MELVAL=IVAL(2)
  1218.                       IGMN1=MIN(IGAU,VELCHE(/1))
  1219.                       IBMN1=MIN(IB  ,VELCHE(/2))
  1220.                       XTT1=VELCHE(IGMN1,IBMN1)
  1221.                       MPTVAL=IVAGR2
  1222.                       MELVAL=IVAL(2)
  1223.                       IGMN2=MIN(IGAU,VELCHE(/1))
  1224.                       IBMN2=MIN(IB  ,VELCHE(/2))
  1225.                       XTT2=VELCHE(IGMN2,IBMN2)
  1226.                       MPTVAL=IVARES
  1227.                       MELVAL=IVAL(2)
  1228.                       VELCHE(IGAU,IB)=XTT1*XTT2
  1229.                    ENDIF
  1230. C                 3e composante 
  1231.                    IF (NGRA1.EQ.3) THEN
  1232.                       MPTVAL=IVAGR1
  1233.                       MELVAL=IVAL(3)
  1234.                       IGMN1=MIN(IGAU,VELCHE(/1))
  1235.                       IBMN1=MIN(IB  ,VELCHE(/2))
  1236.                       XTT1=VELCHE(IGMN1,IBMN1)
  1237.                       MPTVAL=IVAGR2
  1238.                       MELVAL=IVAL(3)
  1239.                       IGMN2=MIN(IGAU,VELCHE(/1))
  1240.                       IBMN2=MIN(IB  ,VELCHE(/2))
  1241.                       XTT2=VELCHE(IGMN2,IBMN2)
  1242.                       MPTVAL=IVARES
  1243.                       MELVAL=IVAL(3)
  1244.                       VELCHE(IGAU,IB)=XTT1*XTT2
  1245.                    ENDIF
  1246. *
  1247. C Gradient du deplacement (9 composantes, quel que soit IDIM)
  1248.                 ELSEIF (NGRA1.EQ.9) THEN 
  1249.                    DO 503 ID=1,3
  1250.                       CC=0.D0
  1251.                       DO 504 JA=1,3
  1252.                          MPTVAL=IVAGR1
  1253.                          MELVAL=IVAL(JA)
  1254.                          IGMN1=MIN(IGAU,VELCHE(/1))
  1255.                          IBMN1=MIN(IB  ,VELCHE(/2))
  1256.                          XTT1=VELCHE(IGMN1,IBMN1)
  1257. *     
  1258.                          JB=3*(JA-1)+ID
  1259. *
  1260.                          MPTVAL=IVAGR2
  1261.                          MELVAL=IVAL(JB)
  1262.                          IGMN2=MIN(IGAU,VELCHE(/1))
  1263.                          IBMN2=MIN(IB  ,VELCHE(/2))
  1264.                          XTT2=VELCHE(IGMN2,IBMN2)
  1265. *
  1266.                          CC = CC + XTT1 * XTT2
  1267.  504                  CONTINUE
  1268.                       MPTVAL=IVARES
  1269.                       MELVAL=IVAL(ID)
  1270.                       VELCHE(IGAU,IB)=CC
  1271.  503               CONTINUE
  1272. *
  1273.                    DO 505 ID=4,6
  1274.                       CC=0.D0
  1275.                       DO 506 JA=4,6
  1276.                          MPTVAL=IVAGR1
  1277.                          MELVAL=IVAL(JA)
  1278.                          IGMN1=MIN(IGAU,VELCHE(/1))
  1279.                          IBMN1=MIN(IB  ,VELCHE(/2))
  1280.                          XTT1=VELCHE(IGMN1,IBMN1)
  1281. *
  1282.                          JB=3*(JA-5)+ID
  1283. *
  1284.                          MPTVAL=IVAGR2
  1285.                          MELVAL=IVAL(JB)
  1286.                          IGMN2=MIN(IGAU,VELCHE(/1))
  1287.                          IBMN2=MIN(IB  ,VELCHE(/2))
  1288.                          XTT2=VELCHE(IGMN2,IBMN2)
  1289. *
  1290.                          CC = CC + XTT1 * XTT2
  1291.  506                  CONTINUE
  1292.                       MPTVAL=IVARES
  1293.                       MELVAL=IVAL(ID)
  1294.                       VELCHE(IGAU,IB)=CC
  1295.  505               CONTINUE
  1296. *     
  1297.                    DO 507 ID=7,9
  1298.                       CC=0.D0
  1299.                       DO 508 JA=7,9
  1300.                          MPTVAL=IVAGR1
  1301.                          MELVAL=IVAL(JA)
  1302.                          IGMN1=MIN(IGAU,VELCHE(/1))
  1303.                          IBMN1=MIN(IB  ,VELCHE(/2))
  1304.                          XTT1=VELCHE(IGMN1,IBMN1)
  1305. *
  1306.                          JB=3*(JA-9)+ID
  1307. *
  1308.                          MPTVAL=IVAGR2
  1309.                          MELVAL=IVAL(JB)
  1310.                          IGMN2=MIN(IGAU,VELCHE(/1))
  1311.                          IBMN2=MIN(IB  ,VELCHE(/2))
  1312.                          XTT2=VELCHE(IGMN2,IBMN2)
  1313. *
  1314.                          CC = CC + XTT1 * XTT2
  1315.  508                  CONTINUE
  1316.                       MPTVAL=IVARES
  1317.                       MELVAL=IVAL(ID)
  1318.                       VELCHE(IGAU,IB)=CC
  1319.  507               CONTINUE
  1320.                 ELSE
  1321.                    CALL ERREUR(26) 
  1322.                    GOTO 5998
  1323.                 ENDIF
  1324.  5020        CONTINUE
  1325.  502      CONTINUE
  1326. *
  1327.           if (ivagr1.ne.0) CALL DTMVAL(IVAGR1,1)
  1328.           if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1329.           IF (IVARES.NE.0) CALL DTMVAL(IVARES,1)
  1330. *
  1331.           NOMID=MOGRA1
  1332.           if(lsupg1)SEGSUP NOMID
  1333.           IF (MOGRA2.NE.MOGRA1) THEN
  1334.              NOMID=MOGRA2
  1335.              if(lsupg2)SEGSUP NOMID
  1336.           ENDIF
  1337. *
  1338. *            SEGSUP INFO
  1339.           GOTO 200
  1340. *
  1341. *           ERREUR DESACTIVATION ET RETOUR
  1342. *
  1343.  5999     CONTINUE
  1344.           if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1345. *
  1346.  5998     CONTINUE
  1347.           if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1348.           NOMID=MOGRA1
  1349.           if(lsupg1)SEGSUP NOMID
  1350.           IF (MOGRA1.NE.MOGRA2) THEN
  1351.              NOMID=MOGRA2
  1352.              if(lsupg2)SEGSUP NOMID
  1353.           ENDIF
  1354. *     SEGSUP INFO
  1355.           SEGSUP MCHELM
  1356.           RETURN
  1357.        ENDIF
  1358. *
  1359.  200  CONTINUE
  1360. *
  1361. *     FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  1362. *     DESACTIVATON DES SEGMENTS
  1363. *
  1364.       IF (K.NE.4 .AND. K.NE.5) THEN
  1365.          SEGSUP MTRAA
  1366.       ENDIF
  1367. *
  1368.       RETURN
  1369. *
  1370.  9999 CONTINUE
  1371.       SEGSUP MCHELM
  1372.       SEGSUP MTRAA
  1373. *
  1374.   666 CONTINUE
  1375.       IPCHMU=0
  1376.  
  1377.       RETURN
  1378.       END
  1379.  
  1380.  

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