Télécharger la plaquette Cast3M


fr en

Télécharger adchve.eso

Retour à la liste

Numérotation des lignes : 

adchve

  1. C ADCHVE    SOURCE    SP204843  24/10/25    21:15:03     12048          
  2.  
  3.       SUBROUTINE ADCHVE(IELVA1,IELVA2,XX,ICOD,IMELVA,IRET)
  4.  
  5. *_______________________________________________________________________
  6. *
  7. *             POUR VECTORISER L ADDITION DES CHAMELEMS
  8. *
  9. *   ENTREE :
  10. *   ________
  11. *
  12. *       IELVA1       POINTEUR SUR LE MELVAL DU 1IER CHAMELEM
  13. *       IELVA2       POINTEUR SUR LE MELVA DU 2IEME CHAMELEM
  14. *       XX           COEFFICIENTS MULTIPLICATEUR
  15. *       ICOD         =1 --> MELVAL DE POINTEUR SUR MLREEL
  16. *                    =2 --> MELVAL DE POINTEUR SUR UN POINT
  17. *                    =3 --> MELVAL DE POINTEUR SUR UN EVOLUTIOn
  18. *                    =0 --> AUTRE CAS
  19. *
  20. *
  21. *   SORTIES :
  22. *   ---------
  23. *
  24. *       IMELVA       POINTEUR SUR LE MELVAL RESULTAT
  25. *       IRET         = 0 SI OK / =1 SINON
  26. *                    =104 POUR DECLENCHER LE MESSAGE D'ERREUR 104
  27. *                    =197 POUR DECLENCHER LE MESSAGE D'ERREUR 197
  28. *
  29. *      EBERSOLT DECEMBRE 86
  30. *
  31. *      PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90
  32. * +PP     EXTENSION ADDITION P.PEGON 23/11/92
  33. *
  34. *______________________________________________________________________
  35. *
  36.       IMPLICIT INTEGER(I-N)
  37.       IMPLICIT REAL*8(A-H,O-Z)
  38.  
  39.  
  40. -INC PPARAM
  41. -INC CCOPTIO
  42.  
  43. -INC SMCHAML
  44. -INC SMLREEL
  45. -INC SMCOORD
  46. -INC SMEVOLL
  47. *
  48.       IRET=0
  49.       MELVA1=IELVA1
  50.       MELVA2=IELVA2
  51.       SEGACT MELVA1
  52.       SEGACT MELVA2
  53. *
  54.       NBP1=MELVA1.VELCHE(/1)
  55.       IF (NBP1.LE.0) THEN
  56.          NBP1=MELVA1.IELCHE(/1)
  57.          IF (NBP1.LE.0) THEN
  58. C          write(6,*) 'IELVA1,IELVA2=',IELVA1,IELVA2
  59. C          write(6,*) '*** Dans adchve' 
  60.            CALL ERREUR(5)
  61.            RETURN
  62.          ENDIF
  63.          NBP2=MELVA2.IELCHE(/1)
  64.          NEL1=MELVA1.IELCHE(/2)
  65.          NEL2=MELVA2.IELCHE(/2)
  66.          N1PTEL=0
  67.          N1EL  =0
  68.          N2PTEL=MAX(NBP1,NBP2)
  69.          N2EL  =MAX(NEL1,NEL2)
  70.          SEGINI MELVAL
  71.          IF (ICOD.EQ.1) THEN
  72.            DO 1 IB = 1, N2EL
  73.              IBMN1 = MIN(IB  ,NEL1)
  74.              IBMN2 = MIN(IB  ,NEL2)
  75.  
  76.              DO 11 IGAU = 1, N2PTEL
  77.                IGMN1 = MIN(IGAU,NBP1)
  78.                IGMN2 = MIN(IGAU,NBP2)
  79. *
  80.                MLREE1 = MELVA1.IELCHE(IGMN1,IBMN1)
  81.                MLREE2 = MELVA2.IELCHE(IGMN2,IBMN2)
  82. *
  83.                IF (MLREE1.EQ.0) THEN
  84.                  MLREEL = MLREE2
  85.                ELSE IF (MLREE2.EQ.0) THEN
  86.                  MLREEL = MLREE1
  87.                ELSE
  88.                  SEGACT,MLREE1,MLREE2
  89.                  JG1 = MLREE1.PROG(/1)
  90.                  JG2 = MLREE2.PROG(/1)
  91.                  IJG = MIN(JG1,JG2)
  92. *
  93.                  JG=MAX(JG1,JG2)
  94.                  SEGINI MLREEL
  95.                  DO 2 IPROG=1,IJG
  96.                     PROG(IPROG)=MLREE1.PROG(IPROG)+XX*MLREE2.PROG(IPROG)
  97.  2               CONTINUE
  98.                  IF (JG.GT.IJG) THEN
  99.                    IF (IJG.EQ.JG1) THEN
  100.                      DO 10 IPROG=IJG+1,JG2
  101.                        PROG(IPROG)=XX*MLREE2.PROG(IPROG)
  102.  10                  CONTINUE
  103.                    ELSE
  104.                      DO 20 IPROG=IJG+1,JG1
  105.                        PROG(IPROG)=MLREE1.PROG(IPROG)
  106.  20                  CONTINUE
  107.                    ENDIF
  108.                  ENDIF
  109.                ENDIF
  110.                IELCHE(IGAU,IB)=MLREEL
  111.  11         CONTINUE
  112.  1          CONTINUE
  113.  
  114.          ELSE IF (ICOD.EQ.2) THEN
  115.             IDIMP1 = IDIM + 1
  116.             mcoact=0
  117.             DO 3 IB=1,N2EL
  118.               IBMN1 = MIN(IB  ,NEL1)
  119.               IBMN2 = MIN(IB  ,NEL2)
  120.  
  121.               DO 31 IGAU=1,N2PTEL
  122.                 IGMN1 = MIN(IGAU,NBP1)
  123.                 IGMN2 = MIN(IGAU,NBP2)
  124. *
  125.                 IP1 = MELVA1.IELCHE(IGMN1,IBMN1)
  126.                 IP2 = MELVA2.IELCHE(IGMN2,IBMN2)
  127. *
  128.                 IF (IP1.EQ.0) THEN
  129.                   NUMNOE = IP2
  130.                 ELSE IF (IP2.EQ.0) THEN
  131.                   NUMNOE = IP1
  132.                 ELSE
  133.                   NUMNOE = MIN(IP1,IP2)
  134. C- Si les numeros des points sont differents, on va tester s'ils
  135. C- n'ont pas les memes coordonnees. Si non, on cree un nouveau point
  136. C- mais risque de probleme en //...
  137.                   IF (IP1.NE.IP2) THEN
  138.                     IREF1 = (IP1-1) * IDIMP1
  139.                     IREF2 = (IP2-1) * IDIMP1
  140.                     i_z = 0
  141.                     if (mcoact.eq.0) then
  142.                      mcoact=1
  143.                      segact mcoord
  144.                     endif
  145.                     DO IC = 1, IDIM
  146.                       r_z1 = MAX( ABS(XCOOR(IREF1+IC)) ,
  147.      &                            ABS(XCOOR(IREF2+IC)) )
  148.                       r_z2 = ABS( XCOOR(IREF1+IC) - XCOOR(IREF2+IC) )
  149.                       IF (r_z2 .GT. 1.D-9*r_z1) i_z = i_z + 1
  150.                     ENDDO
  151. *
  152. *                    ON CREE UN NOUVEAU POINT :
  153. *
  154.                     IF (i_z.GT.0) THEN
  155.  
  156.                       if (mcoact.ne.2) then
  157.                        mcoact=2
  158.                        segact mcoord*mod
  159.                       endif
  160.                       IREFC = NBPTS * IDIMP1
  161.                       NBPTS = NBPTS + 1
  162.                       SEGADJ,MCOORD
  163.                       DO 4 IC = 1, IDIMP1
  164.                         XCOOR(IREFC+IC) =       XCOOR(IREF1+IC)
  165.      &                                    +XX * XCOOR(IREF2+IC)
  166.  4                    CONTINUE
  167.                       NUMNOE = NBPTS
  168.                     ENDIF
  169.                   ENDIF
  170.                 ENDIF
  171.                 IELCHE(IGAU,IB) = NUMNOE
  172.  31           CONTINUE
  173.  3          CONTINUE
  174.             if (mcoact.ne.0) SEGDES,MCOORD
  175.  
  176.          ELSE IF (ICOD.EQ.3) THEN
  177.             I_XX = INT(XX)
  178.             DO 6 IB=1,N2EL
  179.               IBMN1 = MIN(IB  ,NEL1)
  180.               IBMN2 = MIN(IB  ,NEL2)
  181.  
  182.               DO 61 IGAU=1,N2PTEL
  183.                 IGMN1 = MIN(IGAU,NBP1)
  184.                 IGMN2 = MIN(IGAU,NBP2)
  185. *
  186.                 MEVOL1 = MELVA1.IELCHE(IGMN1,IBMN1)
  187.                 MEVOL2 = MELVA2.IELCHE(IGMN2,IBMN2)
  188.                 CALL ADEVOL(MEVOL1,MEVOL2,IPEVAD,I_XX)
  189.                 IF (IPEVAD.EQ.0) IRET=1
  190.                 IELCHE(IGAU,IB) = IPEVAD
  191.  61           CONTINUE
  192.  6          CONTINUE
  193.  
  194.          ELSE
  195. *
  196. *           Y-A-T'IL UN DES DEUX POINTEURS NUL ?
  197. *
  198.             DO IB=1,N2EL
  199.               IBMN1 = MIN(IB  ,NEL1)
  200.               IBMN2 = MIN(IB  ,NEL2)
  201.  
  202.               DO IGAU=1,N2PTEL
  203.                 IGMN1 = MIN(IGAU,NBP1)
  204.                 IGMN2 = MIN(IGAU,NBP2)
  205.  
  206.                 IEL1=MELVA1.IELCHE(IGMN1,IBMN1)
  207.                 IEL2=MELVA2.IELCHE(IGMN2,IBMN2)
  208.                 IF (IEL1.EQ.0)THEN
  209.                   IELCHE(IGAU,IB)=IEL2
  210.                 ELSEIF(IEL2.EQ.0)THEN
  211.                   IELCHE(IGAU,IB)=IEL1
  212.                 ELSE
  213. *
  214. *                 NOM DE COMPOSANTE NON RECONNU
  215. *
  216.                   IRET=197
  217.                   SEGSUP MELVAL
  218.                   RETURN
  219.                 ENDIF
  220.               ENDDO
  221.             ENDDO
  222.          ENDIF
  223.  
  224.          IMELVA=MELVAL
  225.  
  226.       ELSE
  227.          NBP1=MELVA1.VELCHE(/1)
  228.          NBP2=MELVA2.VELCHE(/1)
  229.          NEL1=MELVA1.VELCHE(/2)
  230.          NEL2=MELVA2.VELCHE(/2)
  231.          N1PTEL=MAX(NBP1,NBP2)
  232.          N1EL  =MAX(NEL1,NEL2)
  233.          N2PTEL=0
  234.          N2EL  =0
  235.          SEGINI MELVAL
  236.          DO 50 IB=1,N1EL
  237.            IBMN1 = MIN(IB  ,NEL1)
  238.            IBMN2 = MIN(IB  ,NEL2)
  239.  
  240.            DO 51 IGAU=1,N1PTEL
  241.               IGMN1 = MIN(IGAU,NBP1)
  242.               IGMN2 = MIN(IGAU,NBP2)
  243.               VELCHE(IGAU,IB)=    MELVA1.VELCHE(IGMN1,IBMN1)+
  244.      &                         XX*MELVA2.VELCHE(IGMN2,IBMN2)
  245.   51       CONTINUE
  246.   50     CONTINUE
  247.          IMELVA=MELVAL
  248.  
  249.       ENDIF
  250.  
  251.       END
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  

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