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

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