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

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