Télécharger la plaquette Cast3M


fr en

Télécharger meladd.eso

Retour à la liste

Numérotation des lignes : 

meladd

  1. C MELADD    SOURCE    GOUNAND   26/07/06    21:15:06     12593          
  2.  
  3. *----------------------------------------------------------------------*
  4. *   ADDITION DE 2 MELVALS, LE SECOND ETANT AJOUTE AU PREMIER.
  5. *----------------------------------------------------------------------*
  6. * ENTREES :
  7. *   IELVA1   MELVAL A COMPLETER    <- ACTif et MOD en Entree/Sortie
  8. *   IELVA2   MELVAL A AJOUTER      <- ACTif en Entree/Sortie
  9. *   TYPCHA   TYPE DES CHAMPS CI-DESSUS ADDITIONNER
  10. *   ILEL21   = 0 si les maillages des melvals se correspondent element
  11. *                par element
  12. *            = MLENTI(>0) liste d'entiers donnant la correspondance
  13. *              des elements du champ2 presents dans le champ1 (addition
  14. *              des valeurs commmunes)
  15. *
  16. * SORTIES :
  17. *   IELVA1   MELVAL RESULTAT COMPLETE  <- ACTif et MOD en Sortie
  18. *   IRET     = 0 si pas d'erreur
  19. *            = entier non nul correspondant a l'erreur :
  20. *              104, 21, 197 par ex.
  21. *----------------------------------------------------------------------*
  22.  
  23.       SUBROUTINE MELADD (IELVA1,IELVA2,TYPCHA,ILEL21,IRET)
  24.  
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8(A-H,O-Z)
  27.  
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31.  
  32. -INC SMCHAML
  33.  
  34. -INC SMCOORD
  35. -INC SMLENTI
  36. -INC SMLREEL
  37.       segment ielpo(ig,jg)
  38.       logical lnogr
  39.  
  40.       CHARACTER*(*) TYPCHA
  41.  
  42.       IRET = 0
  43.       melva1 = IELVA1
  44.       melva2 = IELVA2
  45. *      SEGACT,melva1*MOD   <- suppose ACTif et MOD en Entree
  46. *      SEGACT melva2       <- suppose ACTif en Entree
  47.       ielpo = ILEL21
  48.       lnogr=.false.
  49. *      if (ielpo.ne.0) segprt,ielpo
  50.       if (ielpo.ne.0) lnogr = (ielpo(/1).eq.2)
  51. *      write(ioimp,*) 'MELADD: lnogr=',lnogr
  52. *      IF (ielpo.NE.0) SEGACT,ielpo  <- suppose ACTif en Entree
  53.  
  54. * 1---------------------------1
  55. * 1. MELVAL a valeurs reelles :
  56. * 1---------------------------1
  57.       IF (TYPCHA.EQ.'REAL*8') THEN
  58.         nbpi1  = melva1.velche(/1)
  59.         nbel1  = melva1.velche(/2)
  60.         nbpi2  = melva2.velche(/1)
  61.         nbel2  = melva2.velche(/2)
  62.  
  63. * "Extension" de melva1 par rapport a melva2 (MELEXT)
  64.         nbpie = nbpi2
  65.         IF (ielpo.NE.0) THEN
  66.           nbele = ielpo(/2)
  67.           IF (nbel1.GT.1 .AND. nbel1.NE.nbele) THEN
  68.             write(ioimp,*) 'MELADD : nbele .NE. nbel1 > 1 !'
  69.             call erreur(5)
  70.           ENDIF
  71.         ELSE
  72.           nbele = nbel2
  73.           IF (nbel1.GT.1 .AND. nbel2.GT.1 .AND. nbel1.NE.nbel2) THEN
  74.             write(ioimp,*) 'MELADD : nbel2 .NE. nbel1 > 1 !'
  75.             call erreur(5)
  76.           ENDIF
  77.         ENDIF
  78.         CALL MELEXT(melva1,nbpie,nbele)
  79.  
  80. * Addition des valeurs de melva2 dans melva1 pour les elements communs :
  81.         nbpi1  = melva1.velche(/1)
  82.         nbel1  = melva1.velche(/2)
  83.         DO iel1 = 1, nbel1
  84.           iel2 = iel1
  85.           IF (ielpo.NE.0) iel2 = ielpo(1,iel1)
  86.           IF (iel2.GT.0) THEN
  87.              jel2 = MIN(iel2,nbel2)
  88.              if (.not.lnogr) then
  89.                 DO igau1 = 1, nbpi1
  90.                    igau2 = MIN(igau1,nbpi2)
  91.                    melva1.velche(igau1,iel1) =  melva1.velche(igau1
  92.      $                  ,iel1)+ melva2.velche(igau2,jel2)
  93.                 ENDDO
  94.              else
  95.                 ipo2 = ielpo(2,iel1)
  96.                 DO igau1 = 1, nbpi1
  97.                    igau2 = MOD(ipo2+igau1-2,nbpi1)+1
  98.                    igau2 = MIN(igau2,nbpi2)
  99. *                   write(ioimp,*) 'ipo2,igau1,igau2=',ipo2,igau1,igau2
  100.                    melva1.velche(igau1,iel1) =  melva1.velche(igau1
  101.      $                  ,iel1)+ melva2.velche(igau2,jel2)
  102.                 ENDDO
  103.              endif
  104.           ENDIF
  105.         ENDDO
  106.  
  107. * 2------------------------------------2
  108. * 2. MELVAL a valeurs de type pointeur :
  109. * 2------------------------------------2
  110.       ELSE
  111.         nbpi1  = melva1.ielche(/1)
  112.         nbel1  = melva1.ielche(/2)
  113.         nbpi2  = melva2.ielche(/1)
  114.         nbel2  = melva2.ielche(/2)
  115.  
  116. * "Extension" de melva1 par rapport a melva2 (MELEXT)
  117.         nbpie = nbpi2
  118.         IF (ielpo.NE.0) THEN
  119.           nbele = ielpo(/2)
  120.           IF (nbel1.GT.1 .AND. nbel1.NE.nbele) THEN
  121.             write(ioimp,*) 'MELADD : nbele .NE. nbel1 > 1 !'
  122.             call erreur(5)
  123.           ENDIF
  124.         ELSE
  125.           nbele = nbel2
  126.           IF (nbel1.GT.1 .AND. nbel2.GT.1 .AND. nbel1.NE.nbel2) THEN
  127.             write(ioimp,*) 'MELADD : nbel2 .NE. nbel1 > 1 !'
  128.             call erreur(5)
  129.           ENDIF
  130.         ENDIF
  131.         CALL MELEXT(melva1,nbpie,nbele)
  132.  
  133. * Addition des valeurs de melva2 dans melva1 pour les elements communs :
  134.         nbpi1  = melva1.ielche(/1)
  135.         nbel1  = melva1.ielche(/2)
  136.         IF (TYPCHA.EQ.'POINTEURLISTREEL') THEN
  137.           DO iel1 = 1, nbel1
  138.             iel2 = iel1
  139.             IF (ielpo.NE.0) iel2 = ielpo(1,iel1)
  140.             IF (iel2.GT.0) THEN
  141.               jel2 = MIN(iel2,nbel2)
  142.               IF (lnogr) ipo2=ielpo(2,iel1)
  143.               DO igau1 = 1, nbpi1
  144.                 if (lnogr) then
  145.                    igau2=MOD(ipo2+igau1-2,nbpi1)+1
  146.                 else
  147.                    igau2=igau1
  148.                 endif
  149.                 igau2 = MIN(igau2,nbpi2)
  150.                 mlree1 = melva1.ielche(igau1,iel1)
  151.                 mlree2 = melva2.ielche(igau2,jel2)
  152.                 IF (mlree1.EQ.0) THEN
  153.                   melva1.ielche(igau1,iel1) = mlree2
  154.                 ELSE IF (mlree2.NE.0) THEN
  155.                   SEGACT,mlree1*MOD
  156.                   SEGACT,mlree2
  157.                   jg1 = mlree1.prog(/1)
  158.                   jg2 = mlree2.prog(/1)
  159.                   IF (jg2.LE.jg1) THEN
  160.                     DO i = 1, jg2
  161.                       mlree1.prog(i) = mlree1.prog(i) + mlree2.prog(i)
  162.                     ENDDO
  163.                   ELSE
  164.                     jg = jg2
  165.                     SEGADJ,mlree1
  166.                     DO i = 1, jg1
  167.                       mlree1.prog(i) = mlree1.prog(i) + mlree2.prog(i)
  168.                     ENDDO
  169.                     DO i = jg1+1, jg2
  170.                       mlree1.prog(i) = mlree2.prog(i)
  171.                     ENDDO
  172.                   ENDIF
  173. **                SEGDES,mlree1,mlree2
  174. ** on ne desactive pas, on se contente de remettre en lecture seule
  175.                   SEGACT mlree1
  176.                 ENDIF
  177.               ENDDO
  178.             ENDIF
  179.           ENDDO
  180.         ELSE IF (TYPCHA.EQ.'POINTEURPOINT   ') THEN
  181. * Probleme en // car modif. mcoord bloque les assistants en deadlock.
  182. * Se pose aussi la question de la legalite de l'operation effectuee
  183. * ici sur les points = directions.
  184.           idimp1 = IDIM + 1
  185.           nbnoe = nbpts
  186.           nbpts = nbnoe
  187. **          nbpts = nbpts + (nbpi1 * nbel1)
  188. **          SEGADJ,mcoord
  189.  
  190.           DO iel1 = 1, nbel1
  191.             iel2 = iel1
  192.             IF (ielpo.NE.0) iel2 = ielpo(1,iel1)
  193.             IF (iel2.GT.0) THEN
  194.               jel2 = MIN(iel2,nbel2)
  195.               IF (lnogr) ipo2=ielpo(2,iel1)
  196.               DO igau1 = 1, nbpi1
  197.                 if (lnogr) then
  198.                    igau2=MOD(ipo2+igau1-2,nbpi1)+1
  199.                 else
  200.                    igau2=igau1
  201.                 endif
  202.                 igau2 = MIN(igau2,nbpi2)
  203.                 ip1 = melva1.ielche(igau1,iel1)
  204.                 ip2 = melva2.ielche(igau2,jel2)
  205.                 IF (ip1.EQ.0) THEN
  206.                   melva1.ielche(igau1,iel1) = ip2
  207.                 ELSE IF (ip2.NE.0) THEN
  208. C- Si les numeros des points sont differents, on va tester s'ils
  209. C- n'ont pas les memes coordonnees. Si non, alors erreur 5...
  210.                   IF (ip1.NE.ip2) THEN
  211.                     iref1 = (ip1-1) * idimp1
  212.                     iref2 = (ip2-1) * idimp1
  213.                     i_z = 0
  214.                     DO i = 1, idim
  215.                       r_z1 = MAX( ABS(xcoor(iref1+i)) ,
  216.      &                            ABS(xcoor(iref2+i)) )
  217.                       r_z2 = ABS( xcoor(iref1+i) - xcoor(iref2+i) )
  218.                       IF (r_z2 .GT. 1.D-9*r_z1) i_z = i_z + 1
  219.                     ENDDO
  220.                     IF (i_z.GT.0) nbnoe = nbnoe + 1
  221. ** A voir par la suite : tester aussi si les 2 points/vecteurs sont
  222. ** colineaires (produit vectoriel nul). Si oui, on conserve ip1 (en
  223. ** esperant celui-ci non nul).
  224. **                    ireff = nbnoe * idimp1
  225. **                    DO i = 1, idimp1
  226. **                      xcoor(ireff+i) = xcoor(iref1+i) + xcoor(iref2+i)
  227. **                    ENDDO
  228. **                    nbnoe = nbnoe + 1
  229. **                    melva1.ielche(igau1,iel1) = nbnoe
  230.                   ENDIF
  231.                 ENDIF
  232.               ENDDO
  233.             ENDIF
  234.           ENDDO
  235.  
  236.           IF (nbnoe.NE.nbpts) THEN
  237.             write(ioimp,*) ' Cas NON prevu sur les POINTs dans MELADD'
  238.             CALL ERREUR(5)
  239. **            nbpts = nbnoe
  240. **            SEGADJ,mcoord
  241.           ENDIF
  242.  
  243.         ELSE IF (TYPCHA.EQ.'POINTEUREVOLUTIO') THEN
  244.           i_xx = 1
  245.           DO iel1 = 1, nbel1
  246.             iel2 = iel1
  247.             IF (ielpo.NE.0) iel2 = ielpo(1,iel1)
  248.             IF (iel2.GT.0) THEN
  249.               jel2 = MIN(iel2,nbel2)
  250.               IF (lnogr) ipo2=ielpo(2,iel1)
  251.               DO igau1 = 1, nbpi1
  252.                 if (lnogr) then
  253.                    igau2=MOD(ipo2+igau1-2,nbpi1)+1
  254.                 else
  255.                    igau2=igau1
  256.                 endif
  257.                 igau2 = MIN(igau2,nbpi2)
  258.                 ievol1 = melva1.ielche(igau1,iel1)
  259.                 ievol2 = melva2.ielche(igau2,jel2)
  260.                 IF (ievol1.EQ.0) THEN
  261.                   melva1.ielche(igau1,iel1) = ievol2
  262.                 ELSE IF (ievol2.NE.0) THEN
  263.                   CALL ADEVOL(ievol1,ievol2,ievolf,i_xx)
  264.                   IF (ievolf.EQ.0) IRET = 21
  265.                   melva1.ielche(igau1,iel1) = ievolf
  266.                 ENDIF
  267.               ENDDO
  268.             ENDIF
  269.           ENDDO
  270.  
  271.         ELSE
  272.           DO iel1 = 1, nbel1
  273.             iel2 = iel1
  274.             IF (ielpo.NE.0) iel2 = ielpo(1,iel1)
  275.             IF (iel2.GT.0) THEN
  276.               jel2 = MIN(iel2,nbel2)
  277.               IF (lnogr) ipo2=ielpo(2,iel1)
  278.               DO igau1 = 1, nbpi1
  279.                 if (lnogr) then
  280.                    igau2=MOD(ipo2+igau1-2,nbpi1)+1
  281.                 else
  282.                    igau2=igau1
  283.                 endif
  284.                 igau2 = MIN(igau2,nbpi2)
  285.                 ip1 = melva1.ielche(igau1,iel1)
  286.                 ip2 = melva2.ielche(igau2,jel2)
  287.                 IF (ip1.EQ.0) THEN
  288.                   melva1.ielche(igau1,iel1) = ip2
  289.                 ELSE IF (ip2.NE.0) THEN
  290.                   melva1.ielche(igau1,iel1) = 0
  291.                   IRET = 197
  292.                 ENDIF
  293.               ENDDO
  294.             ENDIF
  295.           ENDDO
  296.  
  297.         ENDIF
  298.  
  299.       ENDIF
  300.  
  301. *      SEGDES,melva1,melva2  <- Segments ACTifs en Sortie
  302.  
  303.       RETURN
  304.       END
  305.  
  306.  

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