Télécharger la plaquette Cast3M


fr en

Télécharger expche.eso

Retour à la liste

Numérotation des lignes : 

expche

  1. C EXPCHE    SOURCE    CB215821  20/11/04    21:17:02     10766          
  2.       SUBROUTINE EXPCHE(IPCHEL,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL)
  3. *
  4. *   EXTRAIRE LE OU LES POINTS SUPPORTS DU MAXI OU DU MINI DES VALEURS DE
  5. *   COMPOSANTES D'UN CHAMP/ELEMENT
  6. *
  7. ************************************************************************
  8. *   ENTREES :
  9. *
  10. *     IPCHEL = POINTEUR SUR UN MCHAML
  11. *     IMM    = 1  MAXI , 2 MINI , 3 A 8  AUTRES
  12. *     IAB    = 0 VALEURS ALGEBRIQUES  ,1 VALEURS ABSOLUES
  13. *     IAV    = 1 LES NOMS DE LA LISEMOTS SONT CONSIDERES ,2 ILS SONT EXC
  14. *     IPLIS  = POINTEUR SUR UN LISTMOTS
  15. *     VALREF = VALEUR DE REFERENCE
  16. *     VALRE2 = IDEM POUR OPTION COMPRIS
  17. *
  18. *    SORTIES :
  19. *
  20. *    IPMAIL  = POINTEUR  SUR OBJET MAILLAGE CONTENANT LE OU LES POINTS
  21. *              SUPPORTS DU MAXI OU DU MINI
  22. *
  23. *  P DOWLATYARI OCT 91
  24. ************************************************************************
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8(A-H,O-Z)
  27. *
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCREEL
  31. -INC SMCHAML
  32. -INC SMELEME
  33. -INC SMCOORD
  34. -INC SMLMOTS
  35. -INC SMINTE
  36. *
  37.       SEGMENT QUELCO
  38.         INTEGER ICO(NCOMX,NSOUS)
  39.       ENDSEGMENT
  40. *
  41.       SEGMENT XE(3,NBNN1)
  42.  
  43. *     MACRO ESOPE des options possibles
  44.       MACRO, (MAXI,MINI,SUPE,EGSU,EGAL,EGIN,INFE,DIFF,COMP)
  45.  
  46.       CHARACTER*(LOCOMP) MOCOMP
  47. *
  48. *     INITIALISATIONS
  49. *
  50.       QUELCO=0
  51.       XE    =0
  52.       IPMAIL=0
  53.  
  54.       IF(IAB.EQ.0)THEN
  55.         IF    (IMM.EQ.MAXI)THEN
  56.           VALRE1=-XGRAND
  57.         ELSEIF(IMM.EQ.MINI)THEN
  58.           VALRE1= XGRAND
  59.         ELSE
  60.           VALRE1=VALREF
  61.         ENDIF
  62.  
  63.       ELSE
  64.         IF    (IMM.EQ.MAXI)THEN
  65.           VALRE1=0.D0
  66.         ELSEIF(IMM.EQ.MINI)THEN
  67.           VALRE1= XGRAND
  68.         ELSE
  69.           VALRE1=VALREF
  70.         ENDIF
  71.       ENDIF
  72.  
  73.       IF(IPLIS.NE.0)THEN
  74.          MLMOTS=IPLIS
  75.          NC    =MLMOTS.MOTS(/2)
  76.       ENDIF
  77.  
  78. C     RECUPERE LE CHAMELEM
  79.       MCHELM=IPCHEL
  80.       NSOUS =IMACHE(/1)
  81.  
  82.       IF(IPLIS.NE.0) THEN
  83. *       RECHERCHE LE NOMBRE MAXIMALE DE COMPOSANTES POUR LE SEGMENT QUELCO
  84.         NCOMX = 0
  85.         DO 10 ISOUS=1,NSOUS
  86.           MCHAML=ICHAML(ISOUS)
  87.           NCOMX =MAX(NCOMX,NOMCHE(/2))
  88.   10    CONTINUE
  89.         SEGINI,QUELCO
  90.       ENDIF
  91.  
  92. *     BOUCLE SUR LES SOUS-ZONES POUR DETERMINER QUELLES COMPOSANTES SERONT TRAITEES
  93.       NCOTOT=0
  94.       IMINTE=0
  95.       NBELEM=0
  96.       DO 500 ISOUS=1,NSOUS
  97.         MCHAML=ICHAML(ISOUS)
  98.         NCOMP =NOMCHE(/2)
  99.  
  100.         IF(IPLIS.NE.0)THEN
  101.           NCO=0
  102.           DO 20 ICOMP=1,NCOMP
  103.             MOCOMP=NOMCHE(ICOMP)
  104.             CALL PLACE(MOTS,NC,IX,MOCOMP)
  105.             IF(IAV.EQ.1)THEN
  106.               IF(IX.NE.0)THEN
  107.                 QUELCO.ICO(ICOMP,ISOUS)=1
  108.                 NCO=NCO+1
  109.               ELSE
  110.                 QUELCO.ICO(ICOMP,ISOUS)=0
  111.               ENDIF
  112.  
  113.             ELSE
  114.               IF(IX.EQ.0)THEN
  115.                 QUELCO.ICO(ICOMP,ISOUS)=1
  116.                 NCO=NCO+1
  117.               ELSE
  118.                 QUELCO.ICO(ICOMP,ISOUS)=0
  119.               ENDIF
  120.             ENDIF
  121.  20       CONTINUE
  122.           NCOTOT=NCOTOT+NCO
  123.         ELSE
  124.           NCO=NCOMP
  125.         ENDIF
  126.  
  127.         IF(NCO .GT. 0)THEN
  128.           MINTE =INFCHE(ISOUS,4)
  129.           IPT1  =IMACHE(ISOUS)
  130.           NBEL1 =IPT1.NUM(/2)
  131.           IF (MINTE .NE. 0)THEN
  132.             IMINTE=1
  133.             NBPGAU=MINTE.POIGAU(/1)
  134.           ELSE
  135.             NBPGAU=IPT1.NUM(/1)
  136.           ENDIF
  137.           NBELEM=NBELEM + (NBEL1 * NBPGAU)
  138.         ENDIF
  139. *
  140.         IF(IMM.EQ.MAXI .OR. IMM.EQ.MINI) THEN
  141. C         Determine le MAXI ou le MINI parmi les composantes demandees
  142.           DO 100 ICOMP=1,NCOMP
  143.             IF(IPLIS.NE.0) THEN
  144.                IF(QUELCO.ICO(ICOMP,ISOUS) .EQ. 0)GOTO 100
  145.             ENDIF
  146.             MELVAL=IELVAL(ICOMP)
  147.             NEL   =VELCHE(/2)
  148.             NBPTEL=VELCHE(/1)
  149.             DO 110 IB=1,NEL
  150.               DO 120 IGAU=1,NBPTEL
  151.                 XX=VELCHE(IGAU,IB)
  152.                 IF(IAB.EQ.1) XX = ABS(XX)
  153.                 IF(IMM.EQ.MAXI)THEN
  154.                   VALRE1=MAX(XX,VALRE1)
  155.                 ELSE
  156.                   VALRE1=MIN(XX,VALRE1)
  157.                 ENDIF
  158.  120          CONTINUE
  159.  110        CONTINUE
  160.  100      CONTINUE
  161.         ENDIF
  162.  500  CONTINUE
  163.  
  164. C     ERREUR si aucune composante a traiter ? ==> MAILLAGE VIDE + SOUCIS ?
  165.       IF(IPLIS.NE.0)THEN
  166.         IF(NCOTOT .EQ. 0)THEN
  167.           NBNN  =1
  168.           NBELEM=0
  169.           NBSOUS=0
  170.           NBREF =0
  171.           SEGINI,MELEME
  172.           IPMAIL=MELEME
  173.           MELEME.ITYPEL=1
  174.  
  175. C         Emission d'un soucis 280 : "Composante inexistante"
  176.           CALL soucis(280)
  177.           RETURN
  178.         ENDIF
  179.       ENDIF
  180. *
  181. *   CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS
  182. *
  183.       NBNN=1
  184.       IF(IMINTE .NE. 0)THEN
  185. *       Il va falloir creer au plus NBELEM points
  186.         SEGACT,MCOORD*MOD
  187.         NBPT1 = NBPTS
  188.         NBPTS = NBPTS + NBELEM
  189.         SEGADJ,MCOORD
  190.       ENDIF
  191.  
  192.       NBMAX =NBELEM
  193.  
  194.       NBSOUS=0
  195.       NBREF =0
  196.       SEGINI,MELEME
  197.       IPMAIL=MELEME
  198.       ITYPEL=1
  199.       NBELEM=0
  200. *
  201. *    DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  202. *
  203.       DO 600 ISOUS=1,NSOUS
  204. *
  205.         MCHAML=ICHAML(ISOUS)
  206.         NCOMP =NOMCHE(/2)
  207.         MINTE =INFCHE(ISOUS,4)
  208.         IPT1  =IMACHE(ISOUS)
  209.         NBNN1 =IPT1.NUM(/1)
  210.         NBEL1 =IPT1.NUM(/2)
  211.         IF(MINTE.NE.0)THEN
  212.           NBPGAU=MINTE.POIGAU(/1)
  213.           IF (XE .EQ. 0)THEN
  214.             SEGINI,XE
  215.           ELSEIF(NBNN1 .GT.XE(/2) )THEN
  216.             SEGADJ,XE
  217.           ENDIF
  218.         ELSE
  219.           NBPGAU=NBNN1
  220.         ENDIF
  221.  
  222.         DO 300 ICOMP=1,NCOMP
  223.           IF(IPLIS.NE.0) THEN
  224.              IF(QUELCO.ICO(ICOMP,ISOUS) .EQ. 0)GOTO 300
  225.           ENDIF
  226.           MELVAL=IELVAL(ICOMP)
  227.           NBPTEL=VELCHE(/1)
  228.           NEL   =VELCHE(/2)
  229.           DO 400 IB=1,NBEL1
  230.             DO 410 IGAU=1,NBPGAU
  231.               XX=VELCHE(MIN(IGAU,NBPTEL),MIN(IB,NEL))
  232.               IF(IAB.EQ.1)XX=ABS(XX)
  233.  
  234. *             Enumeration des differentes options
  235.               XPREC=ABS(VALRE1)*XZPREC
  236.               XDIFF=XX-VALRE1
  237.  
  238.               CASE, IMM
  239.               WHEN, MAXI,MINI,EGAL
  240.                 IF(ABS(XDIFF).GT.XPREC ) GOTO 410
  241.               WHEN,SUPE
  242.                 IF(XDIFF.LE.XPREC) GOTO 410
  243.               WHEN,EGSU          
  244.                 IF(XDIFF.LT.-XPREC) GOTO 410
  245.               WHEN,EGIN          
  246.                 IF(XDIFF.GT.XPREC) GOTO 410
  247.               WHEN,INFE          
  248.                 IF(XDIFF.GE.-XPREC) GOTO 410
  249.               WHEN,DIFF
  250.                 IF(ABS(XDIFF).LE.XPREC ) GOTO 410
  251.               WHEN,COMP
  252.                 XDIFF2=VALRE2-XX
  253.                 IF((XDIFF.GE.-XPREC).AND.(XDIFF2.LE.XPREC))GOTO 410
  254.               ENDCASE
  255.  
  256.               NBELEM=NBELEM+1
  257.               IF(MINTE.EQ.0)THEN
  258.                 IPTS1=IPT1.NUM(IGAU,IB)
  259.  
  260.               ELSE
  261.                  CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE(1,1))
  262.                  XC=0.D0
  263.                  YC=0.D0
  264.                  ZC=0.D0
  265.                  DO 405 IE=1,NBNN1
  266.                    XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE)
  267.                    YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE)
  268.                    ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE)
  269.  405             CONTINUE
  270.                  NBPT1=NBPT1+1
  271.                  XCOOR((NBPT1-1)*(IDIM+1)+1)=XC
  272.                  XCOOR((NBPT1-1)*(IDIM+1)+2)=YC
  273.                  IF(IDIM.EQ.3)
  274.      1           XCOOR((NBPT1-1)*(IDIM+1)+3)=ZC
  275.                  IPTS1=NBPT1
  276.               ENDIF
  277.               NUM(1,NBELEM)=IPTS1
  278.  
  279.  410        CONTINUE
  280.  400      CONTINUE
  281.  300    CONTINUE
  282.  600  CONTINUE
  283.  
  284.       IF(NBELEM .LT. NBMAX)SEGADJ,MELEME
  285.  
  286.       IF(IMINTE .NE. 0)THEN
  287. *       Ajustement du MCOORD
  288.         IF(NBPT1 .LT. NBPTS)THEN
  289.           NBPTS = NBPT1
  290.           SEGADJ,MCOORD
  291.         ENDIF
  292.         SEGDES,MCOORD
  293.       ENDIF
  294.  
  295.       IF(IPLIS.NE.0)SEGSUP,QUELCO
  296.       IF(XE   .NE.0)SEGSUP,XE
  297.       END
  298.  
  299.  
  300.  

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