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

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