Télécharger la plaquette Cast3M


fr en

Télécharger muposc.eso

Retour à la liste

Numérotation des lignes : 

muposc

  1. C MUPOSC    SOURCE    CB215821  26/08/24    21:17:30     12622          
  2.       SUBROUTINE MUPOSC(IPOI1,IPOI2,IEPS,IRET)
  3. C=======================================================================
  4. C
  5. C  ENTREE
  6. C     IPOI1=CHPOINT
  7. C     IPOI2=CHPOINT
  8. C     IEPS =1  MULTIPLICATION   -1  DIVISION
  9. C  SORTIES
  10. C     IRET =POINTEUR SUR  CHPOINT RESULTANT
  11. C          =0   SINON (UN MESSAGE D ERREUR EST ALORS IMPRIME )
  12. C
  13. C  REGLE DE MULTIPLICATION : TOUT POINT AYANT DANS UN CHPOINT UNE
  14. C  COMPOSANTE UNIQUE DE NOM "SCAL" VOIT TOUTES LES VALEURS DES
  15. C  COMPOSANTES DE L'AUTRE CHPOINT MULTIPLIER PAR LA VALEUR SCALAIRE.
  16. C
  17. C  LE CHPOINT RESULTAT NE COMPORTE QUE LES POINTS CITES CI-DESSUS.
  18. C
  19. C=======================================================================
  20.       IMPLICIT INTEGER(I-N)
  21.       IMPLICIT REAL*8(A-H,O-Z)
  22. -INC SMCHPOI
  23. -INC SMCOORD
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC SMELEME
  28. -INC TMTRAV
  29.       SEGMENT ICPR(nbpts)
  30.       SEGMENT ICOR(nbpts)
  31.       SEGMENT ICOM(0)
  32.       SEGMENT SCOM
  33.        CHARACTER*(LOCOMP) COM(0)
  34.       ENDSEGMENT
  35.       SEGMENT NOHA(0)
  36.  
  37.  
  38.       CHARACTER*4 MOTCLE(3),MONATU(1)
  39.       DATA MOTCLE/'INDE','DIFF','DISC'/
  40.       DATA MONATU/'NATU'/
  41.  
  42.  
  43.  
  44.       IRET=0
  45.       MCHPO1=IPOI1
  46.       MCHPO2=IPOI2
  47.       MCHPOI=MCHPO1
  48.       IPASS=0
  49.       IA=0
  50.       SEGINI ICPR ,SCOM ,NOHA
  51. C
  52. C     ON FABRIQUE MTRAV A LA DIMENSION MAX   POUR CELA FABRICATION DE
  53. C     ICPR QUI DONNE NNNOE PUIS DE ICOM QUI SERA NNIN
  54.  1000 CONTINUE
  55.       SEGACT MCHPOI
  56.       NSOUP =IPCHP(/1)
  57.  
  58.       DO 1 I = 1,NSOUP
  59.         MSOUPO=IPCHP(I)
  60.         SEGACT MSOUPO
  61.         IF(I.EQ.1.AND.IPASS.EQ.0) THEN
  62.           COM(**)=NOCOMP(1)
  63.           NOHA(**)=NOHARM(1)
  64.         ENDIF
  65.  
  66.         DO 2 J=1,NOCOMP(/2)
  67.           NNIN=COM(/2)
  68.           DO 3 K=1,NNIN
  69.             IF(NOCOMP(J).EQ.COM(K)) GO TO 2
  70.   3       CONTINUE
  71.  
  72.           COM(**) =NOCOMP(J)
  73.           NOHA(**)=NOHARM(J)
  74.   2     CONTINUE
  75.  
  76.         MELEME=IGEOC
  77.         SEGACT MELEME
  78.  
  79.         DO 4 J=1,NUM(/2)
  80.           IF(ICPR(NUM(1,J)).NE.0) GO TO 4
  81.           IA=IA+1
  82.           ICPR(NUM(1,J))=IA
  83.     4   CONTINUE
  84.     1 CONTINUE
  85.  
  86.       IF(IIMPI.NE.0) WRITE(IOIMP,100) IA
  87.  
  88.  100  FORMAT(' NOMBRE DE NOEUDS CONCERNES PAR LES 2 CHPOINTS',I5)
  89.       IF(IPASS.EQ.0) THEN
  90.         IPASS=1
  91.         MCHPOI=MCHPO2
  92.         GO TO 1000
  93.       ENDIF
  94.       NNNOE=IA
  95.       NNIN=COM(/2)
  96.       SEGINI MTRAV
  97. C
  98. C     ON REMPLIT INCO ET IGEO
  99. C
  100.       DO 5 I=1,NNIN
  101.         NHAR(I)=NOHA(I)
  102.         INCO(I)=COM(I)
  103.    5  CONTINUE
  104.  
  105.       SEGSUP SCOM,NOHA
  106.       MCHPOI=MCHPO1
  107.       IPASS=0
  108.  
  109. 1001  CONTINUE
  110.       SEGACT MCHPOI
  111.       NSOUP = IPCHP(/1)
  112.  
  113.       DO 6 I=1,NSOUP
  114.         MSOUPO=IPCHP(I)
  115.         SEGACT MSOUPO
  116.         MELEME=IGEOC
  117.         SEGACT MELEME
  118.  
  119.         DO 7 J = 1,NUM(/2)
  120.           IA=ICPR(NUM(1,J))
  121.           IGEO(IA)=NUM(1,J)
  122.  7      CONTINUE
  123.    6  CONTINUE
  124.  
  125.       IF(IPASS.EQ.0) THEN
  126.       IPASS=1
  127.       MCHPOI=MCHPO2
  128.       GO TO 1001
  129.       ENDIF
  130. C
  131. C  ON EFFECTUE LE TRAVAIL. ON ISOLE D'ABORD LA PARTIE CONCERNANT
  132. C  UNIQUEMENT UNE COMPOSANTE DE NOM "SCAL".
  133. C
  134.       MCHPOI=MCHPO1
  135.       MCHPO3=MCHPO2
  136.       IPASS=0
  137.  
  138.  1003 CONTINUE
  139.       SEGACT MCHPO3
  140.  
  141.       DO 10 I=1,MCHPO3.IPCHP(/1)
  142.       MSOUP3=MCHPO3.IPCHP(I)
  143.       SEGACT MSOUP3
  144.       IF(MSOUP3.NOCOMP(/2).NE.1.OR.MSOUP3.NOCOMP(1).NE.'SCAL') THEN
  145.       GO TO 10
  146.       ENDIF
  147. C ON FABRIQUE UNE CORRESPONDANCE ICOR(I)=J VEUT DIRE QUE LE NOEUD I EST
  148. C EN J EME POSITION DANS CE MELEME
  149. C
  150.       SEGINI ICOR
  151.       IPT3=MSOUP3.IGEOC
  152.       SEGACT IPT3
  153.       DO 11 J=1,IPT3.NUM(/2)
  154.       ICOR(IPT3.NUM(1,J))=J
  155.    11 CONTINUE
  156.       MPOVA3=MSOUP3.IPOVAL
  157.       SEGACT MPOVA3
  158.       SEGACT MCHPOI
  159.       DO 12 J=1,IPCHP(/1)
  160.       MSOUPO=IPCHP(J)
  161.       SEGACT MSOUPO
  162.       IF(IPASS.NE.0) THEN
  163. C  TEST POUR NE PAS REFAIRE LA MULTIPLICATION SCAL PAR SCAL
  164.       IF(NOCOMP(/2).EQ.1.AND.NOCOMP(1).EQ.'SCAL') THEN
  165.       GO TO 12
  166.       ENDIF
  167.       ENDIF
  168.       SEGINI ICOM
  169.       DO 1004 K=1,NOCOMP(/2)
  170.       DO 13 L=1,NNIN
  171.       IF(NOCOMP(K).EQ.INCO(L)) ICOM(**) = L
  172.    13 CONTINUE
  173.  1004 CONTINUE
  174.       MELEME=IGEOC
  175.       MPOVAL=IPOVAL
  176.       SEGACT MELEME,MPOVAL
  177.       DO 14 K=1,NUM(/2)
  178.       IC=ICOR(NUM(1,K))
  179.       IF(IC.EQ.0) GO TO 14
  180.       IB=ICPR(NUM(1,K))
  181.       DO 15 L=1,NOCOMP(/2)
  182.       IE=ICOM(L)
  183.       IBIN(IE,IB)=1
  184.       IF(IEPS.EQ.1)BB(IE,IB)=BB(IE,IB)+MPOVA3.VPOCHA(IC,1)*VPOCHA(K,L)
  185.       IF(IEPS.EQ.-1)BB(IE,IB)=BB(IE,IB)+VPOCHA(K,L)/MPOVA3.VPOCHA(IC,1)
  186.   15  CONTINUE
  187.   14  CONTINUE
  188.       SEGSUP ICOM
  189.   12  CONTINUE
  190.       SEGSUP ICOR
  191.   10  CONTINUE
  192.       IF(IPASS.EQ.0) THEN
  193.       MCHPOI=MCHPO2
  194.       MCHPO3=MCHPO1
  195.       IPASS=1
  196.       GO TO 1003
  197.       ENDIF
  198.       KTRAV=MTRAV
  199. CSG Emettre une erreur ne semble pas forcément utile
  200. CSG On laisse la création d'un chpoint vide par CRECHP
  201. C      DO 50 I=1,NNIN
  202. C      DO 50 J=1,NNNOE
  203. C      IF(IBIN(I,J).NE.0) GO TO 60
  204. C  50  CONTINUE
  205. C      CALL ERREUR(179)
  206. C      SEGSUP MTRAV,ICPR
  207. C      RETURN
  208. C   60 CONTINUE
  209.       CALL CRECHP(KTRAV,IRET)
  210.  
  211.  
  212. C     nature du champoint
  213.       MCHPO3 = IRET
  214.       SEGACT,MCHPO1
  215.       SEGACT,MCHPO2
  216.       SEGACT,MCHPO3*MOD
  217.       CALL LIRMOT(MONATU,1,IVAL,0)
  218.  
  219.       IF ( IVAL .EQ.1 ) THEN
  220. C       Cas de la lecture imposée de la 'NATURE' du champ résultat
  221.         CALL LIRMOT(MOTCLE,3,IVAL,1)
  222.         IF ( IERR .NE. 0) RETURN
  223.         MCHPO3.JATTRI(1) = IVAL-1
  224.  
  225.       ELSE
  226. C       Cas du calcul de la 'NATURE' du champ résultat
  227.         NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1)
  228.         IF ( NATRI .EQ. 0) THEN
  229.             MCHPO3.JATTRI(1) = 0
  230.         ELSE IF ( NATRI .EQ. 1) THEN
  231.             MCHPO3.JATTRI(1) = 1
  232.         ELSE IF ( NATRI .EQ. 2) THEN
  233. C         la nature discrete domine
  234.             MCHPO3.JATTRI(1) = 2
  235.         ELSE
  236.             MCHPO3.JATTRI(1) = 2
  237.         ENDIF
  238.       ENDIF
  239.       IRET=MCHPO3
  240.  
  241.       MTRAV=KTRAV
  242.       SEGSUP MTRAV,ICPR
  243.       END
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  

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