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    PV        20/03/24    21:19:27     10554          
  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.  
  38.       CHARACTER*(*) TYPCHA
  39.  
  40.       IRET = 0
  41.       melva1 = IELVA1
  42.       melva2 = IELVA2
  43. *      SEGACT,melva1*MOD   <- suppose ACTif et MOD en Entree
  44. *      SEGACT melva2       <- suppose ACTif en Entree
  45.       mlenti = ILEL21
  46. *      IF (mlenti.NE.0) SEGACT,mlenti  <- suppose ACTif en Entree
  47.  
  48. * 1---------------------------1
  49. * 1. MELVAL a valeurs reelles :
  50. * 1---------------------------1
  51.       IF (TYPCHA.EQ.'REAL*8') THEN
  52.         nbpi1  = melva1.velche(/1)
  53.         nbel1  = melva1.velche(/2)
  54.         nbpi2  = melva2.velche(/1)
  55.         nbel2  = melva2.velche(/2)
  56.  
  57. * "Extension" de melva1 par rapport a melva2 (MELEXT)
  58.         nbpie = nbpi2
  59.         IF (mlenti.NE.0) THEN
  60.           nbele = mlenti.lect(/1)
  61.           IF (nbel1.GT.1 .AND. nbel1.NE.nbele) THEN
  62.             write(ioimp,*) 'MELADD : nbele .NE. nbel1 > 1 !'
  63.             call erreur(5)
  64.           ENDIF
  65.         ELSE
  66.           nbele = nbel2
  67.           IF (nbel1.GT.1 .AND. nbel2.GT.1 .AND. nbel1.NE.nbel2) THEN
  68.             write(ioimp,*) 'MELADD : nbel2 .NE. nbel1 > 1 !'
  69.             call erreur(5)
  70.           ENDIF
  71.         ENDIF
  72.         CALL MELEXT(melva1,nbpie,nbele)
  73.  
  74. * Addition des valeurs de melva2 dans melva1 pour les elements communs :
  75.         nbpi1  = melva1.velche(/1)
  76.         nbel1  = melva1.velche(/2)
  77.         DO iel1 = 1, nbel1
  78.           iel2 = iel1
  79.           IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  80.           IF (iel2.GT.0) THEN
  81.             jel2 = MIN(iel2,nbel2)
  82.             DO igau1 = 1, nbpi1
  83.               igau2 = MIN(igau1,nbpi2)
  84.               melva1.velche(igau1,iel1) =  melva1.velche(igau1,iel1)
  85.      &                                   + melva2.velche(igau2,jel2)
  86.             ENDDO
  87.           ENDIF
  88.         ENDDO
  89.  
  90. * 2------------------------------------2
  91. * 2. MELVAL a valeurs de type pointeur :
  92. * 2------------------------------------2
  93.       ELSE
  94.         nbpi1  = melva1.ielche(/1)
  95.         nbel1  = melva1.ielche(/2)
  96.         nbpi2  = melva2.ielche(/1)
  97.         nbel2  = melva2.ielche(/2)
  98.  
  99. * "Extension" de melva1 par rapport a melva2 (MELEXT)
  100.         nbpie = nbpi2
  101.         IF (mlenti.NE.0) THEN
  102.           nbele = mlenti.lect(/1)
  103.           IF (nbel1.GT.1 .AND. nbel1.NE.nbele) THEN
  104.             write(ioimp,*) 'MELADD : nbele .NE. nbel1 > 1 !'
  105.             call erreur(5)
  106.           ENDIF
  107.         ELSE
  108.           nbele = nbel2
  109.           IF (nbel1.GT.1 .AND. nbel2.GT.1 .AND. nbel1.NE.nbel2) THEN
  110.             write(ioimp,*) 'MELADD : nbel2 .NE. nbel1 > 1 !'
  111.             call erreur(5)
  112.           ENDIF
  113.         ENDIF
  114.         CALL MELEXT(melva1,nbpie,nbele)
  115.  
  116. * Addition des valeurs de melva2 dans melva1 pour les elements communs :
  117.         nbpi1  = melva1.ielche(/1)
  118.         nbel1  = melva1.ielche(/2)
  119.         IF (TYPCHA.EQ.'POINTEURLISTREEL') THEN
  120.           DO iel1 = 1, nbel1
  121.             iel2 = iel1
  122.             IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  123.             IF (iel2.GT.0) THEN
  124.               jel2 = MIN(iel2,nbel2)
  125.               DO igau1 = 1, nbpi1
  126.                 igau2 = MIN(igau1,nbpi2)
  127.                 mlree1 = melva1.ielche(igau1,iel1)
  128.                 mlree2 = melva2.ielche(igau2,jel2)
  129.                 IF (mlree1.EQ.0) THEN
  130.                   melva1.ielche(igau1,iel1) = mlree2
  131.                 ELSE IF (mlree2.NE.0) THEN
  132.                   SEGACT,mlree1*MOD
  133.                   SEGACT,mlree2
  134.                   jg1 = mlree1.prog(/1)
  135.                   jg2 = mlree2.prog(/1)
  136.                   IF (jg2.LE.jg1) THEN
  137.                     DO i = 1, jg2
  138.                       mlree1.prog(i) = mlree1.prog(i) + mlree2.prog(i)
  139.                     ENDDO
  140.                   ELSE
  141.                     jg = jg2
  142.                     SEGADJ,mlree1
  143.                     DO i = 1, jg1
  144.                       mlree1.prog(i) = mlree1.prog(i) + mlree2.prog(i)
  145.                     ENDDO
  146.                     DO i = jg1+1, jg2
  147.                       mlree1.prog(i) = mlree2.prog(i)
  148.                     ENDDO
  149.                   ENDIF
  150. **                SEGDES,mlree1,mlree2
  151. ** on ne desactive pas, on se contente de remettre en lecture seule
  152.                   SEGACT mlree1
  153.                 ENDIF
  154.               ENDDO
  155.             ENDIF
  156.           ENDDO
  157.         ELSE IF (TYPCHA.EQ.'POINTEURPOINT   ') THEN
  158. * Probleme en // car modif. mcoord bloque les assistants en deadlock. 
  159. * Se pose aussi la question de la legalite de l'operation effectuee
  160. * ici sur les points = directions.
  161.           idimp1 = IDIM + 1
  162.           nbnoe = nbpts
  163.           nbpts = nbnoe
  164. **          nbpts = nbpts + (nbpi1 * nbel1)
  165. **          SEGADJ,mcoord
  166.  
  167.           DO iel1 = 1, nbel1
  168.             iel2 = iel1
  169.             IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  170.             IF (iel2.GT.0) THEN
  171.               jel2 = MIN(iel2,nbel2)
  172.               DO igau1 = 1, nbpi1
  173.                 igau2 = MIN(igau1,nbpi2)
  174.                 ip1 = melva1.ielche(igau1,iel1)
  175.                 ip2 = melva2.ielche(igau2,jel2)
  176.                 IF (ip1.EQ.0) THEN
  177.                   melva1.ielche(igau1,iel1) = ip2
  178.                 ELSE IF (ip2.NE.0) THEN
  179. C- Si les numeros des points sont differents, on va tester s'ils 
  180. C- n'ont pas les memes coordonnees. Si non, alors erreur 5...
  181.                   IF (ip1.NE.ip2) THEN
  182.                     iref1 = (ip1-1) * idimp1
  183.                     iref2 = (ip2-1) * idimp1
  184.                     i_z = 0
  185.                     DO i = 1, idim
  186.                       r_z1 = MAX( ABS(xcoor(iref1+i)) ,
  187.      &                            ABS(xcoor(iref2+i)) )
  188.                       r_z2 = ABS( xcoor(iref1+i) - xcoor(iref2+i) )
  189.                       IF (r_z2 .GT. 1.D-9*r_z1) i_z = i_z + 1
  190.                     ENDDO
  191.                     IF (i_z.GT.0) nbnoe = nbnoe + 1
  192. ** A voir par la suite : tester aussi si les 2 points/vecteurs sont 
  193. ** colineaires (produit vectoriel nul). Si oui, on conserve ip1 (en 
  194. ** esperant celui-ci non nul). 
  195. **                    ireff = nbnoe * idimp1
  196. **                    DO i = 1, idimp1
  197. **                      xcoor(ireff+i) = xcoor(iref1+i) + xcoor(iref2+i)
  198. **                    ENDDO
  199. **                    nbnoe = nbnoe + 1
  200. **                    melva1.ielche(igau1,iel1) = nbnoe
  201.                   ENDIF
  202.                 ENDIF
  203.               ENDDO
  204.             ENDIF
  205.           ENDDO
  206.  
  207.           IF (nbnoe.NE.nbpts) THEN
  208.             write(ioimp,*) ' Cas NON prevu sur les POINTs dans MELADD'
  209.             CALL ERREUR(5)
  210. **            nbpts = nbnoe
  211. **            SEGADJ,mcoord
  212.           ENDIF
  213.  
  214.         ELSE IF (TYPCHA.EQ.'POINTEUREVOLUTIO') THEN
  215.           i_xx = 1
  216.           DO iel1 = 1, nbel1
  217.             iel2 = iel1
  218.             IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  219.             IF (iel2.GT.0) THEN
  220.               jel2 = MIN(iel2,nbel2)
  221.               DO igau1 = 1, nbpi1
  222.                 igau2 = MIN(igau1,nbpi2)
  223.                 ievol1 = melva1.ielche(igau1,iel1)
  224.                 ievol2 = melva2.ielche(igau2,jel2)
  225.                 IF (ievol1.EQ.0) THEN
  226.                   melva1.ielche(igau1,iel1) = ievol2
  227.                 ELSE IF (ievol2.NE.0) THEN
  228.                   CALL ADEVOL(ievol1,ievol2,ievolf,i_xx)
  229.                   IF (ievolf.EQ.0) IRET = 21
  230.                   melva1.ielche(igau1,iel1) = ievolf
  231.                 ENDIF
  232.               ENDDO
  233.             ENDIF
  234.           ENDDO
  235.  
  236.         ELSE
  237.           DO iel1 = 1, nbel1
  238.             iel2 = iel1
  239.             IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  240.             IF (iel2.GT.0) THEN
  241.               jel2 = MIN(iel2,nbel2)
  242.               DO igau1 = 1, nbpi1
  243.                 igau2 = MIN(igau1,nbpi2)
  244.                 ip1 = melva1.ielche(igau1,iel1)
  245.                 ip2 = melva2.ielche(igau2,jel2)
  246.                 IF (ip1.EQ.0) THEN
  247.                   melva1.ielche(igau1,iel1) = ip2
  248.                 ELSE IF (ip2.NE.0) THEN
  249.                   melva1.ielche(igau1,iel1) = 0
  250.                   IRET = 197
  251.                 ENDIF
  252.               ENDDO
  253.             ENDIF
  254.           ENDDO
  255.  
  256.         ENDIF
  257.  
  258.       ENDIF
  259.  
  260. *      SEGDES,melva1,melva2  <- Segments ACTifs en Sortie
  261.  
  262.       RETURN
  263.       END
  264.  
  265.  
  266.  
  267.  
  268.  

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