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

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