Télécharger la plaquette Cast3M


fr en

Télécharger mschp1.eso

Retour à la liste

Numérotation des lignes : 

mschp1

  1. C MSCHP1    SOURCE    CB215821  20/11/25    13:34:33     10792          
  2.       SUBROUTINE MSCHP1(IPO2,IPO3,X1,IKO,IPO1,ICLE,IRET,ISOM)
  3. C=======================================================================
  4. C  ENTREE
  5. C     IPO1 = POINTEUR SUR LE PREMIER CHPO
  6. C     IPO2 = POINTEUR SUR LE SECOND  CHPO
  7. C     IPO3 = POINTEUR SUR LE TROISIEME  CHPO (OPTION "COMP")
  8. C     X1   = VALEUR MIN OU MAX (OPTION "COMP")
  9. C     IKO  = 0 SI IPO2 PUIS IPO3, 1 SI X1 PUIS IPO2, -1 SI IPO2 PUIS X1
  10. C     ICLE = ENTIER CARACTERISANT LE TYPE DE COMPARAISON
  11. C     ISOM = 1 SI ON VEUT LA SOMME, 0 SINON
  12. C  SORTIE
  13. C     IRET = POINTEUR SUR LE CHAMP RESULTAT SI ISOM=0
  14. C     IRET = SOMME DES 1 ET DES 0           SI ISOM=1
  15. C=======================================================================
  16.       IMPLICIT INTEGER(I-N)
  17.       IMPLICIT REAL*8(A-H,O-Z)
  18. -INC SMCHPOI
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC SMELEME
  23. -INC SMCOORD
  24.  
  25.       SEGMENT/MTRA/(NOPOIN(nbpts))
  26.       SEGMENT MTR1
  27.        CHARACTER*(LOCOMP) IPCOM(0)
  28.       ENDSEGMENT
  29.       SEGMENT/MTR4/(IPHAR(0))
  30.       SEGMENT/MTR2/(IC2CC(NC2))
  31.       SEGMENT MTR3
  32.        REAL*8   BB2(NNIN,NNNOE)
  33.       ENDSEGMENT
  34.       SEGMENT MTR5
  35.        REAL*8   BB3(NNIN,NNNOE)
  36.       ENDSEGMENT
  37. C
  38.       IKOK=IKO
  39.       IF (IKOK.EQ.0.AND.IPO3.LE.0) IKOK=-1
  40. C
  41. C ======================================================================
  42. C REMPLISSAGE DE NOPOIN, IPCOM et BB2
  43. C ======================================================================
  44. C
  45. C ----------------------------------
  46. C ON RECUPERE LES INFOS DU CHPOINT 2
  47. C ----------------------------------
  48.       MCHPOI=IPO2
  49.       NSOUPO=IPCHP(/1)
  50.  
  51. c PREDIMENSIONNEMENT DE IC2CC AU MAX POSSIBLE
  52.       NC2=0
  53.       DO IA=1,NSOUPO
  54.         MSOUPO=IPCHP(IA)
  55.         NC2=NC2+NOCOMP(/2)
  56.       ENDDO
  57.       SEGINI,MTR2
  58.  
  59. c AUTRES INITIALISATIONS
  60.       IK=0
  61.       KSOM=0
  62.       SEGINI,MTRA,MTR1,MTR4
  63.  
  64.  
  65. C BOUCLE SUR LES ZONES DU CHPO 2
  66. C
  67.       DO 20 IA=1,NSOUPO
  68.  
  69.         MSOUPO=IPCHP(IA)
  70.  
  71. *       composantes + harmoniques --> liste locale
  72.         NC=NOCOMP(/2)
  73. *       boucle sur les composantes de cette zone du chpoint
  74.         DO 40 IC=1,NC
  75.           NCC=IPCOM(/2)
  76. *         boucle sur les composantes deja enregistrees
  77.           DO 50 ICC=1,NCC
  78.             IF(IPCOM(ICC).NE.NOCOMP(IC)) GO TO 50
  79.             IF(IPHAR(ICC).EQ.NOHARM(IC)) GO TO 40
  80.    50     CONTINUE
  81. *         nouvelle composante -> on l'enregistre dans la liste complete
  82.           IPCOM(**)=NOCOMP(IC)
  83.           IPHAR(**)=NOHARM(IC)
  84.           NCC=NCC+1
  85.           ICC=NCC
  86.           IC2CC(IC)=ICC
  87.           NC2=MAX(IC,NC2)
  88.    40   CONTINUE
  89.  
  90. *       maillage --> numerotation locale NOPOIN
  91.         MELEME=IGEOC
  92.         NBNN=NUM(/1)
  93.         NBELEM=NUM(/2)
  94.         DO 30 IB=1,NBELEM
  95.           K=NUM(1,IB)
  96.           IF(NOPOIN(K).NE.0) GOTO 30
  97.           IK=IK+1
  98.           NOPOIN(K)=IK
  99.    30   CONTINUE
  100.    20 CONTINUE
  101.       SEGADJ,MTR2
  102.  
  103. C ----------------------------------------------
  104. C ON RECUPERE LES INFOS DU CHPOINT 3 (SI BESOIN)
  105. C ----------------------------------------------
  106.       IF (IKOK.EQ.0) THEN
  107.          MCHPOI=IPO3
  108.          NSOUPO=IPCHP(/1)
  109.  
  110. c PREDIMENSIONNEMENT DE IC2CC AU MAX POSSIBLE
  111.          DO IA=1,NSOUPO
  112.            MSOUPO=IPCHP(IA)
  113.            NC2=NC2+NOCOMP(/2)
  114.          ENDDO
  115.          SEGADJ,MTR2
  116.  
  117. C BOUCLE SUR LES ZONES DU CHPO 2
  118. C
  119.          DO 120 IA=1,NSOUPO
  120.  
  121.            MSOUPO=IPCHP(IA)
  122.  
  123. *          composantes + harmoniques --> liste locale
  124.            NC=NOCOMP(/2)
  125. *          boucle sur les composantes de cette zone du chpoint
  126.            DO 140 IC=1,NC
  127.              NCC=IPCOM(/2)
  128. *            boucle sur les composantes deja enregistrees
  129.              DO 150 ICC=1,NCC
  130.                IF(IPCOM(ICC).NE.NOCOMP(IC)) GOTO 150
  131.                IF(IPHAR(ICC).EQ.NOHARM(IC)) GOTO 140
  132.   150        CONTINUE
  133. *            nouvelle composante -> on l'enregistre dans la liste complete
  134.              IPCOM(**)=NOCOMP(IC)
  135.              IPHAR(**)=NOHARM(IC)
  136.              NCC=NCC+1
  137.              ICC=NCC
  138.              IC2CC(IC)=ICC
  139.              NC2=MAX(IC,NC2)
  140.   140      CONTINUE
  141.  
  142. *          maillage --> numerotation locale NOPOIN
  143.            MELEME=IGEOC
  144.            NBNN=NUM(/1)
  145.            NBELEM=NUM(/2)
  146.            DO 130 IB=1,NBELEM
  147.              K=NUM(1,IB)
  148.              IF(NOPOIN(K).NE.0) GOTO 130
  149.              IK=IK+1
  150.              NOPOIN(K)=IK
  151.   130      CONTINUE
  152.   120    CONTINUE
  153.          SEGADJ,MTR2
  154.       ENDIF
  155.  
  156. C -----------------------------------------------------
  157. C CREATION ET REMPLISSAGE DE BB2 = VALEURS DU CHPOINT 2
  158. C -----------------------------------------------------
  159.  
  160.       MCHPOI=IPO2
  161.       NSOUPO=IPCHP(/1)
  162.       NNIN=NC2
  163.       NNNOE=IK
  164.       SEGINI,MTR3
  165.       DO 21 IA=1,NSOUPO
  166.  
  167.         MSOUPO=IPCHP(IA)
  168.  
  169. *       maillage ET valeur
  170.         MPOVA2=IPOVAL
  171.         MELEME=IGEOC
  172.         NBNN=NUM(/1)
  173.         NBELEM=NUM(/2)
  174.         DO 31 IB=1,NBELEM
  175.           K=NUM(1,IB)
  176.           IK=NOPOIN(K)
  177. *         on en profite pour enregistrer les valeurs du chpo 2
  178. *         --> stockee dans tableau local BB2
  179.           DO 32 IC=1,NC
  180.             ICC=IC2CC(IC)
  181.             BB2(ICC,IK)=MPOVA2.VPOCHA(IB,IC)
  182.    32     CONTINUE
  183.    31   CONTINUE
  184.    21 CONTINUE
  185.  
  186. C -----------------------------------------------------------------
  187. C CREATION ET REMPLISSAGE DE BB3 = VALEURS DU CHPOINT 3 (SI BESOIN)
  188. C -----------------------------------------------------------------
  189.  
  190.       IF (IKOK.EQ.0) THEN
  191.          MCHPOI=IPO3
  192.          NSOUPO=IPCHP(/1)
  193.          NNIN=NC2
  194.          NNNOE=IK
  195.          SEGINI,MTR5
  196.          DO 121 IA=1,NSOUPO
  197.            MSOUPO=IPCHP(IA)
  198.  
  199. *          maillage ET valeur
  200.            MPOVA2=IPOVAL
  201.            MELEME=IGEOC
  202.            NBNN=NUM(/1)
  203.            NBELEM=NUM(/2)
  204.            DO 131 IB=1,NBELEM
  205.              K=NUM(1,IB)
  206.              IK=NOPOIN(K)
  207. *            on en profite pour enregistrer les valeurs du chpo 2
  208. *            --> stockee dans tableau local BB2
  209.              DO 132 IC=1,NC
  210.                ICC=IC2CC(IC)
  211.                BB3(ICC,IK)=MPOVA2.VPOCHA(IB,IC)
  212.   132        CONTINUE
  213.   131      CONTINUE
  214.   121    CONTINUE
  215.       ENDIF
  216.  
  217.  
  218. C ======================================================================
  219. C CREATION DU CHPOINT RESULTAT DEPUIS LE 1ER CHPOINT
  220. C ======================================================================
  221. C
  222.       MCHPO1=IPO1
  223.       SEGINI,MCHPOI=MCHPO1
  224.       ICHPOI=MCHPOI
  225.       MOCHDE='CHPOINT CREE PAR MASQ'
  226.  
  227.       NSOUPO=IPCHP(/1)
  228. C     BOUCLE SUR LES ZONES
  229.       DO 60 IA=1,NSOUPO
  230.  
  231.         MSOUP1=IPCHP(IA)
  232.         SEGINI,MSOUPO=MSOUP1
  233.         IPCHP(IA)=MSOUPO
  234.         NC=NOCOMP(/2)
  235.         MPOVA1=IPOVAL
  236.         SEGINI,MPOVAL=MPOVA1
  237.         IPOVAL=MPOVAL
  238.         MELEME=IGEOC
  239.         NBELEM=NUM(/2)
  240.  
  241. C       BOUCLE SUR LES COMPOSANTES
  242.         DO 70 IC=1,NC
  243.  
  244. C          recherche dans la liste cree depuis le 2eme chpoint
  245.            DO 71 ICC=1,IPCOM(/2)
  246.              IF(IPCOM(ICC).NE.NOCOMP(IC)) GOTO 71
  247.              IF(IPHAR(ICC).EQ.NOHARM(IC)) GOTO 72
  248.    71      CONTINUE
  249. c          on n'a pas trouve de composantes adequates <=> ICC=0
  250.            ICC=0
  251.    72      CONTINUE
  252. c          on a trouve ICC
  253.  
  254. c          BOUCLE SUR LES NOEUDS (le maillage reste le meme que 1er CHPOINT)
  255.            DO 80 IB=1,NBELEM
  256.  
  257.               K=NUM(1,IB)
  258.               IK=NOPOIN(K)
  259. c             si ik=0 OU ICC=0, le point OU la composante n'existe pas
  260. c             dans les autres chpoints  ==>  x2=x3=0 par convention
  261.               IF (ICC.EQ.0.OR.IK.EQ.0) THEN
  262.                 IF (IKOK.EQ.0) THEN
  263.                   X2=0.D0
  264.                   X3=0.D0
  265.                 ELSEIF (IKOK.GT.0) THEN
  266.                   X2=X1
  267.                   X3=0.D0
  268.                 ELSE
  269.                   X2=0.D0
  270.                   X3=X1
  271.                 ENDIF
  272.               ELSE
  273.                 IF (IKOK.EQ.0) THEN
  274.                   X2=BB2(ICC,IK)
  275.                   X3=BB3(ICC,IK)
  276.                 ELSEIF (IKOK.GT.0) THEN
  277.                   X2=X1
  278.                   X3=BB2(ICC,IK)
  279.                 ELSE
  280.                   X2=BB2(ICC,IK)
  281.                   X3=X1
  282.                 ENDIF
  283.               ENDIF
  284. *
  285. C             COMPARAISON PROPREMENT DITE
  286. *
  287. *             -----------------------------------------
  288. *             SOIT ON VEUT UN MASQUE POINT PAR POINT...
  289. *             -----------------------------------------
  290. *
  291.               IF (ISOM.EQ.0) THEN
  292. *
  293. *               MOT-CLE "SUPE"
  294.                 IF (ICLE.EQ.1) THEN
  295.                   IF (VPOCHA(IB,IC).GT.X2) THEN
  296.                     VPOCHA(IB,IC)=1.D0
  297.                   ELSE
  298.                     VPOCHA(IB,IC)=0.D0
  299.                   ENDIF
  300. *
  301. *               MOT-CLE "EGSU"
  302.                 ELSEIF (ICLE.EQ.2) THEN
  303.                   IF (VPOCHA(IB,IC).GE.X2) THEN
  304.                     VPOCHA(IB,IC)=1.D0
  305.                   ELSE
  306.                     VPOCHA(IB,IC)=0.D0
  307.                   ENDIF
  308. *
  309. *               MOT-CLE "EGAL"
  310.                 ELSEIF (ICLE.EQ.3) THEN
  311.                   IF (VPOCHA(IB,IC).EQ.X2) THEN
  312.                     VPOCHA(IB,IC)=1.D0
  313.                   ELSE
  314.                     VPOCHA(IB,IC)=0.D0
  315.                   ENDIF
  316. *
  317. *               MOT-CLE "EGIN"
  318.                 ELSEIF (ICLE.EQ.4) THEN
  319.                   IF (VPOCHA(IB,IC).LE.X2) THEN
  320.                     VPOCHA(IB,IC)=1.D0
  321.                   ELSE
  322.                     VPOCHA(IB,IC)=0.D0
  323.                   ENDIF
  324. *
  325. *               MOT-CLE "INFE"
  326.                 ELSEIF (ICLE.EQ.5) THEN
  327.                   IF (VPOCHA(IB,IC).LT.X2) THEN
  328.                     VPOCHA(IB,IC)=1.D0
  329.                   ELSE
  330.                     VPOCHA(IB,IC)=0.D0
  331.                   ENDIF
  332. *
  333. *               MOT-CLE "DIFF"
  334.                 ELSEIF (ICLE.EQ.6) THEN
  335.                   IF (VPOCHA(IB,IC).NE.X2) THEN
  336.                     VPOCHA(IB,IC)=1.D0
  337.                   ELSE
  338.                     VPOCHA(IB,IC)=0.D0
  339.                   ENDIF
  340. *
  341. *               MOT-CLE "COMP"
  342.                 ELSEIF (ICLE.EQ.7) THEN
  343.                   IF (VPOCHA(IB,IC).GE.X2.AND.VPOCHA(IB,IC).LE.X3) THEN
  344.                     VPOCHA(IB,IC)=1.D0
  345.                   ELSE
  346.                     VPOCHA(IB,IC)=0.D0
  347.                   ENDIF
  348.                 ENDIF
  349. *
  350. *             -----------------------------------------
  351. *             SOIT ON CHERCHE SEULEMENT LA SOMME...
  352. *             -----------------------------------------
  353.               ELSEIF(ISOM.EQ.1) THEN
  354. *
  355. *               MOT-CLE "SUPE"
  356.                 IF (ICLE.EQ.1) THEN
  357.                   IF (VPOCHA(IB,IC).GT.X2) KSOM=KSOM+1
  358. *
  359. *               MOT-CLE "EGSU"
  360.                 ELSEIF(ICLE.EQ.2) THEN
  361.                   IF (VPOCHA(IB,IC).GE.X2) KSOM=KSOM+1
  362. *
  363. *               MOT-CLE "EGAL"
  364.                 ELSEIF(ICLE.EQ.3) THEN
  365.                   IF (VPOCHA(IB,IC).EQ.X2) KSOM=KSOM+1
  366. *
  367. *               MOT-CLE "EGIN"
  368.                 ELSEIF(ICLE.EQ.4) THEN
  369.                   IF (VPOCHA(IB,IC).LE.X2) KSOM=KSOM+1
  370. *
  371. *               MOT-CLE "INFE"
  372.                 ELSEIF(ICLE.EQ.5) THEN
  373.                   IF (VPOCHA(IB,IC).LT.X2) KSOM=KSOM+1
  374. *
  375. *               MOT-CLE "DIFF"
  376.                 ELSEIF(ICLE.EQ.6) THEN
  377.                   IF (VPOCHA(IB,IC).NE.X2) KSOM=KSOM+1
  378. *
  379. *               MOT-CLE "COMP"
  380.                 ELSEIF(ICLE.EQ.7) THEN
  381.                   IF (VPOCHA(IB,IC).GE.X2.AND.VPOCHA(IB,IC).LE.X3)
  382.      &              KSOM=KSOM+1
  383.                 ENDIF
  384.               ENDIF
  385.  
  386.    80      CONTINUE
  387.  
  388.    70   CONTINUE
  389.    60 CONTINUE
  390.  
  391.  
  392. C-----------------------------------------------------------------------
  393. C     NETTOYAGE ET FIN DE PROGRAMME
  394. C-----------------------------------------------------------------------
  395. C
  396.  
  397.       SEGSUP MTRA,MTR1,MTR4,MTR2,MTR3
  398.       IF (IKOK.EQ.0) SEGSUP,MTR5
  399.  
  400.       IF (ISOM.EQ.1) THEN
  401.         SEGSUP,MCHPOI
  402.         IRET=KSOM
  403.       ELSE
  404.         IRET=ICHPOI
  405.       ENDIF
  406.  
  407.  
  408.       RETURN
  409.       END
  410.  
  411.  
  412.  
  413.  
  414.  
  415.  
  416.  
  417.  
  418.  
  419.  

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