Télécharger la plaquette Cast3M


fr en

Télécharger expchp.eso

Retour à la liste

Numérotation des lignes : 

expchp

  1. C EXPCHP    SOURCE    CB215821  20/11/25    13:28:37     10792          
  2.        SUBROUTINE EXPCHP(IPCHPO,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/POINT
  6. *
  7. ************************************************************************
  8. *   ENTREES :
  9. *
  10. *     IPCHPO =POINTEUR SUR UN CHPOINT
  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 OU AUTRES
  22. *
  23. *  P DOWLATYARI OCT 91
  24. ************************************************************************
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8(A-H,O-Z)
  27. *
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCREEL
  32. -INC SMCHPOI
  33. -INC SMELEME
  34. -INC SMCOORD
  35. -INC SMLMOTS
  36. *
  37.       SEGMENT QUELCO
  38.         INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS)
  39.       ENDSEGMENT
  40.       CHARACTER*(LOCOMP) MOCOMP
  41.       DIMENSION  XE(3,1)
  42. *
  43. *       INITIALISATIONS
  44. *
  45.       IF(IAB.EQ.0)THEN
  46.         IF    (IMM.EQ.1)THEN
  47.           VALRE1=-XGRAND
  48.         ELSEIF(IMM.EQ.2)THEN
  49.           VALRE1= XGRAND
  50.         ELSE
  51.           VALRE1=VALREF
  52.         ENDIF
  53.  
  54.       ELSE
  55.         IF    (IMM.EQ.1)THEN
  56.           VALRE1=0.D0
  57.         ELSEIF(IMM.EQ.2)THEN
  58.           VALRE1= XGRAND
  59.         ELSE
  60.           VALRE1=VALREF
  61.         ENDIF
  62.       ENDIF
  63. *
  64.       IF(IPLIS.NE.0)THEN
  65.          MLMOTS=IPLIS
  66.          SEGACT MLMOTS
  67.          NC=MOTS(/2)
  68.       ENDIF
  69. *
  70. *         ON RECUPERE LE CHPOINT
  71. *
  72.       MCHPOI=IPCHPO
  73.       NSOUS = IPCHP(/1)
  74.  
  75. *
  76. *  ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES
  77. *
  78.       NCOMX = 0
  79.       DO 10 ISOUS=1,NSOUS
  80.        MSOUPO=IPCHP(ISOUS)
  81.        NCOMX=MAX(NCOMX,NOCOMP(/2))
  82.   10  CONTINUE
  83. *
  84.       IF(IPLIS.NE.0)SEGINI QUELCO
  85.  
  86. *
  87. *   BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI
  88. *                             SI IMM = 1 OU 2
  89. *
  90.       DO  500 ISOUS=1,NSOUS
  91. *
  92.       MSOUPO=IPCHP(ISOUS)
  93.       NCOMP=NOCOMP(/2)
  94.       IF(IPLIS.NE.0)THEN
  95.        NCO=0
  96.        DO 20 ICOMP=1,NCOMP
  97.        MOCOMP=NOCOMP(ICOMP)
  98.        CALL PLACE(MOTS,NC,IX,MOCOMP)
  99.        IF(IAV.EQ.1)THEN
  100.          IF(IX.NE.0)THEN
  101.             ICO(ISOUS,ICOMP)=1
  102.             NCO=NCO+1
  103.          ELSE
  104.             ICO(ISOUS,ICOMP)=0
  105.          ENDIF
  106.        ELSE
  107.          IF(IX.EQ.0)THEN
  108.             ICO(ISOUS,ICOMP)=1
  109.             NCO=NCO+1
  110.          ELSE
  111.             ICO(ISOUS,ICOMP)=0
  112.          ENDIF
  113.        ENDIF
  114.  20    CONTINUE
  115.        NNCO(ISOUS)=NCO
  116.       ENDIF
  117. *
  118.       IF(IMM.LE.2) THEN
  119.         XMAXI = -XGRAND
  120.         XMINI =  XGRAND
  121.         IF(IPLIS.EQ.0)THEN
  122.           MPOVAL=IPOVAL
  123.           N=VPOCHA(/1)
  124.           DO 100 ICOMP=1,NCOMP
  125.             DO 101 IB=1,N
  126.               XX=VPOCHA(IB,ICOMP)
  127.               IF(IAB.EQ.1)XX=ABS(XX)
  128.               XMAXI=MAX(XX,XMAXI)
  129.               XMINI=MIN(XX,XMINI)
  130.  101        CONTINUE
  131.  100      CONTINUE
  132.  
  133.         ELSEIF(NCO.NE.0)THEN
  134.           MPOVAL=IPOVAL
  135.           N=VPOCHA(/1)
  136.           DO 110 ICOMP=1,NCOMP
  137.             IF(ICO(ISOUS,ICOMP).EQ.0)GOTO 110
  138.             DO 111 IB=1,N
  139.               XX=VPOCHA(IB,ICOMP)
  140.               XMAXI=MAX(XX,XMAXI)
  141.               XMINI=MIN(XX,XMINI)
  142.  111        CONTINUE
  143.  110      CONTINUE
  144.         ENDIF
  145.  
  146.         IF(IMM.EQ.1)THEN
  147.           VALRE1=XMAXI
  148.         ELSE
  149.           VALRE1=XMINI
  150.         ENDIF
  151.       ENDIF
  152. *
  153.  500  CONTINUE
  154.       IF(IPLIS.NE.0)THEN
  155.           NZERO=0
  156.           DO 510 ISOUS=1,NSOUS
  157.           IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1
  158.   510     CONTINUE
  159.        IF(NZERO.EQ.NSOUS)THEN
  160.           CALL ERREUR(280)
  161.           SEGSUP QUELCO
  162.           IPMAIL=0
  163.           RETURN
  164.         ENDIF
  165.       ENDIF
  166. *
  167. *   CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS
  168. *
  169.       NBNN=1
  170.       NBELEM=nbpts
  171.       NBSOUS=0
  172.       NBREF=0
  173.       SEGINI MELEME
  174.       IPMAIL=MELEME
  175.       ITYPEL=1
  176.       NBELEM=0
  177. *
  178. *    DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  179. *
  180.       DO 600 ISOUS=1,NSOUS
  181. *
  182.       MSOUPO=IPCHP(ISOUS)
  183.       NCOMP=NOCOMP(/2)
  184.       IPT1=IGEOC
  185.       IF(IPLIS.EQ.0)THEN
  186.         MPOVAL=IPOVAL
  187.         N=VPOCHA(/1)
  188.         DO 300 ICOMP=1,NCOMP
  189.           DO 301 IB=1,N
  190.             XX=VPOCHA(IB,ICOMP)
  191.             IF(IAB.EQ.1)XX=ABS(XX)
  192.             XPREC=ABS(VALRE1)*XZPREC
  193.             XDIFF=XX - VALRE1
  194. *           
  195. *           TRI SELON LA VALEUR DE IMM
  196. *
  197.             GOTO (21,21,23,24,21,26,27,28,29),IMM
  198. *
  199.             CALL ERREUR(280)
  200.             SEGSUP QUELCO
  201.             IPMAIL=0
  202.             RETURN
  203. *
  204. *  MAXI OU MINI OU EGAL
  205.   21        IF(A_EGALE_B(XX,VALRE1)) GOTO 303
  206.             GOTO 301
  207. *           
  208. * SUPE      
  209.   23        IF(XDIFF.GT.XPREC) GOTO 303
  210.             GOTO 301
  211. *           
  212. * EGSUPE    
  213.   24        IF(XDIFF.GE.-XPREC) GOTO 303
  214.             GOTO 301
  215. *           
  216. * EGINFE    
  217.   26        IF(XDIFF.LE.XPREC) GOTO 303
  218.             GOTO 301
  219. *           
  220. * INFE      
  221.   27        IF(XDIFF.LT.-XPREC) GOTO 303
  222.             GOTO 301
  223. *           
  224. * DIFF      
  225.   28        IF(ABS(XDIFF).GT.XPREC) GOTO 303
  226.             GOTO 301
  227. *           
  228. * COMP      
  229.   29        CONTINUE
  230.             XDIFF2=XX-VALRE2
  231.             IF((XDIFF.GE.-XPREC).AND.(XDIFF2.LE.XPREC)) GOTO 303
  232.             GOTO 301
  233. *
  234.  303        CONTINUE
  235.             NBELEM=NBELEM+1
  236. *           SEGADJ MELEME
  237.             NUM(1,NBELEM)=IPT1.NUM(1,IB)
  238.  301      CONTINUE
  239.  300    CONTINUE
  240. *
  241.       ELSEIF(NNCO(ISOUS).NE.0)THEN
  242.         MPOVAL=IPOVAL
  243.         N=VPOCHA(/1)
  244.         DO 310 ICOMP=1,NCOMP
  245.           IF(ICO(ISOUS,ICOMP).EQ.0)GOTO 310
  246.           DO 410 IB=1,N
  247.             XX=VPOCHA(IB,ICOMP)
  248.             IF(IAB.EQ.1)XX=ABS(XX)
  249.             XPREC=ABS(VALRE1)*XZPREC
  250.             XDIFF=XX-VALRE1
  251. *
  252. *
  253. *           TRI SELON LA VALEUR DE IMM
  254. *
  255.             GOTO (31,31,33,34,31,36,37,38,39),IMM
  256. *
  257.             CALL ERREUR(280)
  258.             SEGSUP QUELCO
  259.             IPMAIL=0
  260.             RETURN
  261. *
  262. *  MAXI OU MINI OU EGAL
  263.   31        IF(A_EGALE_B(XX,VALRE1)) GOTO 413
  264.             GOTO 410
  265. *
  266. * SUPE
  267.   33        IF(XDIFF.GT.XPREC) GOTO 413
  268.             GOTO 410
  269. *
  270. * EGSUPE
  271.   34        IF(XDIFF.GE.-XPREC) GOTO 413
  272.             GOTO 410
  273. *
  274. * EGINFE
  275.   36        IF(XDIFF.LE.XPREC) GOTO 413
  276.             GOTO 410
  277. *
  278. * INFE
  279.   37        IF(XDIFF.LT.-XPREC) GOTO 413
  280.             GOTO 410
  281. *
  282. * DIFF
  283.   38        IF(ABS(XDIFF).GT.XPREC) GOTO 413
  284.             GOTO 410
  285. *
  286. * COMP
  287.   39        CONTINUE
  288.             XDIFF2=XX-VALRE2
  289.             IF((XDIFF.GE.-XPREC).AND.(XDIFF2.LE.XPREC)) GOTO 413
  290.             GOTO 410
  291. *
  292.  413        CONTINUE
  293.             NBELEM=NBELEM+1
  294. *           SEGADJ MELEME
  295.             NUM(1,NBELEM)=IPT1.NUM(1,IB)
  296.  410      CONTINUE
  297.  310    CONTINUE
  298.       ENDIF
  299. *
  300.  600  CONTINUE
  301.       SEGADJ MELEME
  302.       IF(IPLIS.NE.0)SEGSUP QUELCO
  303.       END
  304.  
  305.  
  306.  

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