Télécharger la plaquette Cast3M


fr en

Télécharger adchpo.eso

Retour à la liste

Numérotation des lignes : 

adchpo

  1. C ADCHPO    SOURCE    FANDEUR   22/01/19    21:15:01     11256          
  2.       SUBROUTINE ADCHPO(IPO1,IPO2,IRET,XCO1,XCO2)
  3. C=======================================================================
  4. C
  5. C     COMBINAISON LINEAIRE DE 2 CHPS PAR POINTS
  6. C-----------------------------------------------------------------------
  7. C     ON VEUT FAIRE FLO1*CHP1 + FLO2*CHP2
  8. C-----------------------------------------------------------------------
  9. C  ENTREE
  10. C     IPO1=POINTEUR SUR LE 1 CHAMP PAR POINT
  11. C     IPO2=POINTEUR SUR LE 2 CHAMP PAR POINT
  12. C     XCO1 ET XCO2 COEFFICIENTS APPLIQUES SUR LES CHAMPS
  13. C  SORTIE
  14. C     IRET= POINTEUR SUR LE CHAMP SOMME
  15. C         = 0   SI SOMME IMPOSSIBLE
  16. C
  17. C              MESSAGE D ERREUR DECLENCHE SI IRET=0
  18. C
  19. C     CODE EBERSOLT JUILLET 84  MODIF HAMY NOVEMBRE 84
  20. C
  21. C     POUR L INSTANT ON AUTORISE L ADDITION DE CHPOINTS DE SOUS
  22. C     TYPE DIFFERENTS ( STOCKES DANS MTYPOI )
  23. C
  24. C     CETTE ROUTINE FAIT APPEL A LA ROUTINE CRECHP
  25. C
  26. C=======================================================================
  27.       IMPLICIT INTEGER(I-N)
  28.       IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32.  
  33. -INC SMCHPOI
  34. -INC SMELEME
  35. -INC SMCOORD
  36. -INC TMTRAV
  37.       SEGMENT/MTRA/(NOPOIN(nbpts))
  38.       SEGMENT MTR1
  39.         CHARACTER*(LOCOMP) IPCOM(0)
  40.       ENDSEGMENT
  41.       SEGMENT/MTR2/(IICOM(0))
  42.       SEGMENT/MTR3/(INDEX(max(nsoup1,nsoup2)))
  43.       SEGMENT/MTR4/(IPHAR(0))
  44.       SEGMENT/MTR5/(IPOS1(NSOUP1),IPOS2(NSOUP2),
  45.      >     IZON(nbpts))
  46.       segment mtr6
  47.       character*(LOCOMP) mpcom(ncmax)
  48.       integer     micom(ncmax),nicom(ncmax)
  49.       integer     mphar(ncmax)
  50.       endsegment
  51.  
  52.       character*(LOCOMP)MOCOMP
  53. C
  54. C-----------------------------------------------------------------------
  55. C               --- DESCRIPTION DES SEGMENTS DE TRAVAIL ---
  56. C * MTRAV : - BB(I,J) EST LA VALEUR DE LA IEME INCONNUE DE CHAMP POUR
  57. C          LE JIEME NOEUD DU TABLEAU IGEO .
  58. C           - INCO(NNIN) CONTIENT LE NOM DES NNIN INCONNUES DIFFERENTES
  59. C           - IBIN(I,J)=1 OU 0 INDIQUE QUE LA IEME INCONNUE DU CHAMP
  60. C          EXISTE POUR LE JIEME NOEUD DU TABLEAU IGEO .
  61. C           - IGEO(I) EST LE NUMERO A METTRE DANS UN OBJET MELEME POUR
  62. C          REFERENCER LE IEME NOEUD .
  63. C
  64. C * MTRA  : - NOPOIN(I) ADRESSE DE COLONNE DANS BB ET IBIN DES VALEURS
  65. C          CORRESPONDANT AU NOEUD I .
  66. C
  67. C * MTR1  : - IPCOM LISTE DES NOMS DES INCONNUES PERMET DE CREER INCO .
  68. C
  69. C * MTR2  : - IICOM ADRESSE DANS IPCOM DES INCONNUES CORRESPONDANT AU
  70. C          2IEME CH POINT .
  71. C
  72. C * MTR3  : - INDEX TABLEAU DE CORRESPONDANCE ENTRE LES SUPPORTS GEOME-
  73. C          TRIQUES DU 1ER CHPOINT ET DU 2IEME CHPOINT .
  74. C-----------------------------------------------------------------------
  75.       DIMENSION IPO(2)
  76.       CHARACTER*8 MOT
  77. C
  78.       IF(IPO1.NE.IPO2) GOTO 60
  79. C
  80. C-----------------------------------------------------------------------
  81. C *** CAS OU LES 2 POINTEURS IPO1 ET IPO2 SONT EGAUX
  82. C-----------------------------------------------------------------------
  83. C
  84.       XX = XCO1 + XCO2
  85. C
  86.       if (ierr.ne.0) return
  87. C
  88.       MCHPO1=IPO1
  89.       SEGACT MCHPO1
  90.       NSOUPO=MCHPO1.IPCHP(/1)
  91.       NAT=MCHPO1.JATTRI(/1)
  92.       SEGINI MCHPOI
  93.       DO 10 I=1,NAT
  94.         JATTRI(I)=MCHPO1.JATTRI(I)
  95.  10   CONTINUE
  96.       IRET=MCHPOI
  97.       MOCHDE='CHPOINT cree par ADCHPO'
  98.       MTYPOI=MCHPO1.MTYPOI
  99.       IFOPOI=MCHPO1.IFOPOI
  100.       DO 50 IA=1,NSOUPO
  101.          MSOUP1=MCHPO1.IPCHP(IA)
  102.          SEGACT MSOUP1
  103.          NC=MSOUP1.NOCOMP(/2)
  104.          SEGINI MSOUPO
  105.          IPCHP(IA)=MSOUPO
  106.          DO 20 IB=1,NC
  107.             NOCOMP(IB)=MSOUP1.NOCOMP(IB)
  108.             NOHARM(IB)=MSOUP1.NOHARM(IB)
  109.  20      CONTINUE
  110.          IGEOC=MSOUP1.IGEOC
  111.          MPOVA1=MSOUP1.IPOVAL
  112.          SEGACT MPOVA1
  113.          N  =MPOVA1.VPOCHA(/1)
  114.          NC1=MPOVA1.VPOCHA(/2)
  115.          IF(NC1.EQ.NC)  GOTO 30
  116. C
  117. C     ERREUR PB DIMENSION TABLEAU VOIR ROUTINE ADCHPO
  118. C
  119.          IRET=0
  120.          SEGSUP MSOUPO,MCHPOI
  121.          CALL ERREUR(114)
  122.          RETURN
  123.  30      CONTINUE
  124.          SEGINI MPOVAL
  125.          IPOVAL=MPOVAL
  126.          DO 40 IC=1,NC
  127.             DO 41 IB=1,N
  128.                VPOCHA(IB,IC)=XX*MPOVA1.VPOCHA(IB,IC)
  129.  41         CONTINUE
  130.  40      CONTINUE
  131.  50   CONTINUE
  132.       RETURN
  133. C
  134. C-----------------------------------------------------------------------
  135. C *** CAS  OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS
  136. C-----------------------------------------------------------------------
  137. C
  138.  60   CONTINUE
  139.       IPO(1)=IPO1
  140.       IPO(2)=IPO2
  141.       XXT1 = XCO1
  142.       XXT2 = XCO2
  143.  
  144.       MCHPO1=IPO1
  145.       MCHPO2=IPO2
  146.       if (ierr.ne.0) return
  147.       SEGACT MCHPO1,MCHPO2
  148.       NSOUP1=MCHPO1.IPCHP(/1)
  149.       NSOUP2=MCHPO2.IPCHP(/1)
  150.       NAT1 = MCHPO1.JATTRI(/1)
  151.       NAT2 = MCHPO2.JATTRI(/1)
  152.       MOT = MCHPO1.MTYPOI
  153.       IF(MOT.NE.MCHPO2.MTYPOI) THEN
  154.          MOT='adchpo'
  155.       ENDIF
  156. C
  157. C     ON REGARDE SI UN CHAMP EST INCLUS DANS L'AUTRE
  158. C
  159. C     Cas de l'un ou l'autre des CHPOINT 'VIDE'
  160.       IF    (NSOUP1.EQ.0 .AND. NSOUP2.EQ.0)THEN
  161. C       Cela revient a faire un 'CHPOINT' 'VIDE' en recopiant les attributs
  162.         NSOUPO=0
  163.         NAT   =MAX(NAT1,NAT2,1)
  164.         SEGINI,MCHPOI
  165.         IRET=MCHPOI
  166.         IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  167.            IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  168.               JATTRI(1)= MCHPO1.JATTRI(1)
  169.            ELSE
  170.               JATTRI(1)=0
  171.            ENDIF
  172.         ELSE
  173.            JATTRI(1)=0
  174.         ENDIF
  175.         MTYPOI=MOT
  176.         MOCHDE='CHPOINT cree par ADCHPO'
  177.         IFOPOI=IFOUR
  178.         RETURN
  179.  
  180.       ELSEIF(NSOUP1.EQ.0 .AND. NSOUP2.NE.0)THEN
  181. C       Cela revient a une multiplication de MCHPO2 par XCO2
  182.         IOPERA=2
  183.         IARGU =2
  184.         I1    =0
  185.         CALL OPCHP1(MCHPO2,IOPERA,IARGU,I1,XCO2,IRET,IOK)
  186.         RETURN
  187.  
  188.       ELSEIF(NSOUP1.NE.0 .AND. NSOUP2.EQ.0)THEN
  189. C       Cela revient a une multiplication de MCHPO1 par XCO1
  190.         IOPERA=2
  191.         IARGU =2
  192.         I1    =0
  193.         CALL OPCHP1(MCHPO1,IOPERA,IARGU,I1,XCO1,IRET,IOK)
  194.         RETURN
  195.       ENDIF
  196. C
  197. C Cas general : les 2 champs ne sont pas vides 
  198. C
  199.       ifo1 = MCHPO1.IFOPOI
  200.       ifo2 = MCHPO2.IFOPOI
  201.       ifos = ifo1
  202.       IF (ifo1 .NE. ifo2) THEN
  203.         interr(1)=ifo1
  204.         interr(2)=ifo2
  205.         interr(3)=IFOUR
  206. c-dbg      write(ioimp,*) '1132 ADCHPO',ipo1,ipo2
  207.         call erreur(1132)
  208.         ifos = IFOUR
  209.       END IF
  210. C
  211. C     ON REGARDE SI on peut se passer de repartionner la geometrie
  212. C
  213.       SEGINI MTR5
  214.       SEGINI MTR3
  215.       ncmax2=0
  216.       nposr=0
  217.       DO 100 IB=1,NSOUP2
  218.          MSOUP2=MCHPO2.IPCHP(IB)
  219.          SEGACT MSOUP2
  220.          ncmax2=max(ncmax2,msoup2.nocomp(/2))
  221.          ipt2=MSOUP2.IGEOC
  222.          segact ipt2
  223.          do 101 iel=1,ipt2.num(/2)
  224.             izon(ipt2.num(1,iel))=ib
  225.  101     continue
  226.  100  continue
  227.       ncmax1=0
  228.       do 105 ia=1,nsoup1
  229.          msoup1=mchpo1.ipchp(ia)
  230.          segact msoup1
  231.          ncmax1=max(ncmax1,msoup1.nocomp(/2))
  232.          ipt1=msoup1.igeoc
  233.          segact ipt1
  234.          ib=0
  235.          if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1))
  236.          if (ib.eq.0) then
  237.             do 106 iel=1,ipt1.num(/2)
  238.                if (izon(ipt1.num(1,iel)).ne.0) then
  239.                   if (iimpi.eq.1954)
  240.      >                 write (ioimp,*)
  241.      $                 ' adchpo zone 1ch coupe zone 2ch ',ia
  242.      $                 ,izon(ipt1.num(1,iel))
  243.                   goto 109
  244.                endif
  245.  106        continue
  246.             goto 105
  247.          endif
  248.          MSOUP2=MCHPO2.IPCHP(IB)
  249. *  si meme nombre d'elements on compare les meleme
  250.          ipt2=msoup2.igeoc
  251.          IF(ipt1.eq.ipt2) GO TO 90
  252.          if (ipt1.num(/2).ne.ipt2.num(/2))then
  253.             if (iimpi.eq.1954)
  254.      >           write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2)
  255.      $           ,ipt2.num(/2)
  256.             goto 109
  257.          endif
  258.          do 84 iel=1,ipt1.num(/2)
  259.             if (izon(ipt1.num(1,iel)).ne.ib) then
  260.                if (iimpi.eq.1954)
  261.      >              write (ioimp,*) ' adchpo zone mismatch '
  262.                goto 109
  263.             endif
  264.  84      continue
  265.  90      CONTINUE
  266.          nposr=nposr+1
  267.          ipos1(ia)=1
  268.          ipos2(ib)=1
  269.          INDEX(ia)=IB
  270.  105  CONTINUE
  271.       npaq1=0
  272.       do 82 ipaq=1,nsoup1
  273.          npaq1=npaq1+ipos1(ipaq)
  274.  82   continue
  275.       npaq2=0
  276.       do 83 ipaq=1,nsoup2
  277.          npaq2=npaq2+ipos2(ipaq)
  278.  83   continue
  279.       if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide '
  280.       goto 108
  281.  109  continue
  282. C
  283. C     tous les meleme de l'un ne sont pas inclus dans l'autre
  284. C
  285.       SEGSUP MTR3,MTR5
  286.       GO TO 300
  287.  108  continue
  288. C
  289. C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE
  290. C
  291.       NSOUPO=NSOUP1+NSOUP2-nposr
  292.       NAT=MAX(NAT1,NAT2,1)
  293.       SEGINI MCHPOI
  294.       IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  295.          IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  296.             JATTRI(1)= MCHPO1.JATTRI(1)
  297.          ELSE
  298.             JATTRI(1)=0
  299.          ENDIF
  300.       ELSE
  301.          JATTRI(1)=0
  302.       ENDIF
  303.       IRET=MCHPOI
  304.       MTYPOI=MOT
  305.       MOCHDE='CHPOINT cree par ADCHPO'
  306.       IFOPOI=ifos
  307.       ncmax=ncmax1+ncmax2
  308. *goo      SEGINI mtr6
  309.       nposr=0
  310.       DO 250 IA=1,NSOUP1
  311.          SEGINI mtr6
  312.          if (ipos1(ia).eq.0) goto 250
  313.          MSOUP1=MCHPO1.IPCHP(IA)
  314.          MSOUP2=MCHPO2.IPCHP(INDEX(IA))
  315.          SEGACT MSOUP1,MSOUP2
  316. C
  317. C     COMPARAISON DES NOMS DES COMPOSANTES
  318. C
  319.          NC1=MSOUP1.NOCOMP(/2)
  320.          NC2=MSOUP2.NOCOMP(/2)
  321.          DO 130 IB=1,NC1
  322.             mpcom(ib)=MSOUP1.NOCOMP(IB)
  323.             mphar(ib)=MSOUP1.NOHARM(IB)
  324.  130     CONTINUE
  325.          mc=nc1
  326.          DO 160 IB=1,NC2
  327.             DO 140 IC=1,NC1
  328.                IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
  329.                IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
  330.  140        CONTINUE
  331.             mc=mc+1
  332.             mpcom(mc)=MSOUP2.NOCOMP(IB)
  333.             mphar(mc)=MSOUP2.NOHARM(IB)
  334.             micom(ib)=mc
  335.             GO TO 160
  336.  150        CONTINUE
  337.             micom(ib)=ic
  338.             nicom(ic)=1
  339.  160     CONTINUE
  340. C
  341.          MPOVA1=MSOUP1.IPOVAL
  342.          MPOVA2=MSOUP2.IPOVAL
  343.          SEGACT MPOVA1,MPOVA2
  344.          N1=MPOVA1.VPOCHA(/1)
  345.          N2=MPOVA2.VPOCHA(/1)
  346.          NCX1=MPOVA1.VPOCHA(/2)
  347.          NCX2=MPOVA2.VPOCHA(/2)
  348.          IF(NCX1.NE.NC1) GOTO 170
  349.          IF(NCX2.NE.NC2) GOTO 170
  350.          IF(N1.NE.N2)    GOTO 170
  351.          GOTO 180
  352.  170     CONTINUE
  353.          SEGSUP MTR6,MCHPOI,MTR3,MTR5
  354. C
  355. C     PB AVEC LES DIMENSIONS DES CHPOINTS
  356. C
  357.          CALL ERREUR(114)
  358.          IRET=0
  359.          RETURN
  360. *
  361.  180     CONTINUE
  362. *
  363.          N=N1
  364.          NC=mc
  365.          SEGINI MPOVAL
  366. C
  367. C     recopier le premier chpo
  368. C
  369.          DO 210 IC=1,NC1
  370.             if (nicom(ic).eq.0) then
  371.                DO 200 IB=1,N
  372.                   VPOCHA(IB,IC)=XXT1*MPOVA1.VPOCHA(IB,IC)
  373.  200           CONTINUE
  374.             endif
  375.  210     CONTINUE
  376. C
  377. C     rajouter le second
  378. C
  379.          ipt1=msoup1.igeoc
  380.          ipt2=msoup2.igeoc
  381. *  si les numerotations sont differentes il faut reordonner
  382.          if (ipt1.ne.ipt2) then
  383.             do 229 iel=1,ipt2.num(/2)
  384.                izon(ipt2.num(1,iel))=iel
  385.  229        continue
  386.             DO 230 IC=1,NC2
  387.                IIC=micom(ic)
  388.                if (iic.gt.nc1) then
  389.                   DO 221 IB=1,N
  390.                      VPOCHA(IB,IIC)=XXT2*
  391.      $                    MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
  392.  221              CONTINUE
  393.                else
  394.                   DO 220 IB=1,N
  395.                      VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)
  396.      $                    +XXT2*MPOVA2.VPOCHA(izon(ipt1.num(1,ib))
  397.      $                    ,IC)
  398.  220              CONTINUE
  399.                endif
  400.  230        CONTINUE
  401.          else
  402. *  meme pointeur geometrique on se passe de izon
  403.             DO 235 IC=1,NC2
  404.                IIC=micom(ic)
  405.                if (iic.gt.nc1) then
  406.                   DO 236 IB=1,N
  407.                      VPOCHA(IB,IIC)=XXT2*MPOVA2.VPOCHA(IB,IC)
  408.  236              CONTINUE
  409.                else
  410.                   DO 237 IB=1,N
  411.                      VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)+
  412.      >                    XXT2*MPOVA2.VPOCHA(IB,IC)
  413.  237              CONTINUE
  414.                endif
  415.  235        CONTINUE
  416.          endif
  417. C
  418.          SEGINI MSOUPO
  419.          DO 240 IB=1,NC
  420.             NOCOMP(IB)=mpcom(ib)
  421.             NOHARM(IB)=mphar(ib)
  422.  240     CONTINUE
  423.          IPOVAL=MPOVAL
  424.          IPT3=IPT1
  425.          IGEOC=IPT3
  426.          nposr=nposr+1
  427.          IPCHP(nposr)=MSOUPO
  428.          SEGSUP MTR6
  429.  250  CONTINUE
  430. *goo      SEGSUP MTR6
  431. *  il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement
  432.       DO 251 IA=1,NSOUP1
  433.          if (ipos1(ia).ne.0) goto 251
  434.          nposr=nposr+1
  435.          msoupo=mchpo1.ipchp(ia)
  436.          segini,msoup1=msoupo
  437.          ipchp(nposr)=msoup1
  438.          mpoval=msoup1.ipoval
  439.          segact mpoval
  440.          n=vpocha(/1)
  441.          nc=vpocha(/2)
  442.          segini,mpova1
  443.          do 254 jb=1,nc
  444.             do 2541 ja=1,n
  445.                mpova1.vpocha(ja,jb)=xxt1*vpocha(ja,jb)
  446.  2541       continue
  447.  254     continue
  448.          msoup1.ipoval=mpova1
  449.  251  continue
  450.       DO 252 IB=1,NSOUP2
  451.          if (ipos2(ib).ne.0) goto 252
  452.          nposr=nposr+1
  453.          msoupo=mchpo2.ipchp(ib)
  454.          segini,msoup1=msoupo
  455.          ipchp(nposr)=msoup1
  456.          mpoval=msoup1.ipoval
  457.          segact mpoval
  458.          n=vpocha(/1)
  459.          nc=vpocha(/2)
  460.          segini,mpova1
  461.          do 253 jb=1,nc
  462.             do 2531 ja=1,n
  463.                mpova1.vpocha(ja,jb)=xxt2*vpocha(ja,jb)
  464.  2531       continue
  465.  253     continue
  466.          msoup1.ipoval=mpova1
  467.  252  continue
  468. *  verification que les composantes sont bien differentes entre paquets
  469.       do 255 isoupo=1,ipchp(/1)
  470.          msoup1=ipchp(isoupo)
  471.          SEGACT MSOUP1
  472.          nc1=msoup1.nocomp(/2)
  473.          do 256 jsoupo=isoupo+1,ipchp(/1)
  474.             msoup2=ipchp(jsoupo)
  475.             SEGACT MSOUP2
  476.             nc2=msoup2.nocomp(/2)
  477.             if (nc1.ne.nc2) goto 256
  478.             do 257 ic1=1,nc1
  479.                do 258 ic2=1,nc2
  480.                   if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2))
  481.      $                 goto 258
  482.                   if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2))
  483.      $                 goto 257
  484.  258           continue
  485.                goto 256
  486.  257        continue
  487. *  pas de chance composantes en double
  488.             if (iimpi.eq.1954) write (ioimp,*)
  489.      $           ' pacquets en double => lent '
  490.             segsup mtr3,mtr5
  491.             goto 300
  492.  256     continue
  493.  255  continue
  494.       SEGSUP MTR3,MTR5
  495.  
  496.       RETURN
  497. C
  498. C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES
  499. C *** A UNE PERMUTATION PRES
  500. C
  501.  300  CONTINUE
  502. C
  503.       SEGINI MTRA,MTR1,MTR4
  504. C
  505.       MCHPOI=IPO1
  506.       SEGACT MCHPOI
  507.       MSOUPO=IPCHP(1)
  508.       SEGACT MSOUPO
  509.       IPCOM(**)=NOCOMP(1)
  510.       IPHAR(**)=NOHARM(1)
  511.       NC=1
  512.       IK=0
  513. C
  514. C     CREATION DE NOPOIN ET DE IPCOM
  515. C
  516.       DO 360 ICH=1,2
  517.          MCHPOI=IPO(ICH)
  518.          SEGACT MCHPOI
  519.          NSOUPO=IPCHP(/1)
  520. C
  521. C     BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT
  522. C
  523.          DO 350 IA=1,NSOUPO
  524.             MSOUPO=IPCHP(IA)
  525.             SEGACT MSOUPO
  526.             MELEME=IGEOC
  527.             SEGACT MELEME
  528.             NBNN  =NUM(/1)
  529.             NBELEM=NUM(/2)
  530. C     IF(NBNN.NE.1) GOTO 777
  531.             DO 310 IB=1,NBELEM
  532.                K=NUM(1,IB)
  533.                IF(NOPOIN(K).NE.0) GO TO 310
  534.                IK=IK+1
  535.                NOPOIN(K)=IK
  536.  310        CONTINUE
  537.             NCBBB=NOCOMP(/2)
  538.             DO 330 IB=1,NCBBB
  539.                NC=IPCOM(/2)
  540.                DO 320 IC=1,NC
  541.                   IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  542.                   IF(IPHAR(IC).EQ.NOHARM(IB))  GO TO 330
  543.  320           CONTINUE
  544.                IPCOM(**)=NOCOMP(IB)
  545.                IPHAR(**)=NOHARM(IB)
  546.                NC=NC+1
  547.  330        CONTINUE
  548.  350     CONTINUE
  549.  360  CONTINUE
  550. C
  551.       NNIN=NC
  552.       NNNOE=IK
  553.       SEGINI MTRAV
  554. C
  555. C     CREATION DE INCO
  556. C
  557.       DO 380 IA=1,NNIN
  558.          INCO(IA)=IPCOM(IA)
  559.          NHAR(IA)=IPHAR(IA)
  560.  380  CONTINUE
  561. C
  562. C     CREATION DE BB,IBIN,IGEO
  563. C
  564.       MCHPOI=IPO(1)
  565.       SEGACT MCHPOI
  566.       NSOUPO=IPCHP(/1)
  567.       DO 1430 IA=1,NSOUPO
  568.          MSOUPO=IPCHP(IA)
  569.          SEGACT MSOUPO
  570.          MELEME=IGEOC
  571.          SEGACT MELEME
  572.          MPOVAL=IPOVAL
  573.          SEGACT MPOVAL
  574.          NBELEM=NUM(/2)
  575.          if (nbelem.ne.vpocha(/1)) then
  576.           call erreur(114)
  577.           iret=0
  578.          RETURN
  579.          endif
  580.          N=VPOCHA(/1)
  581.          NC=VPOCHA(/2)
  582.          NC1=NOCOMP(/2)
  583. C
  584.          DO 1420 IB=1,NC1
  585.             DO 1390 IC=1,NNIN
  586.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390
  587.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400
  588.  1390       CONTINUE
  589.  1400       CONTINUE
  590.             DO 1410 ID=1,NBELEM
  591.                KI=NOPOIN(NUM(1,ID))
  592.                IGEO(KI)=NUM(1,ID)
  593.                IBIN(IC,KI)=1
  594.                BB(IC,KI)=XXT1*VPOCHA(ID,IB)
  595.  1410       CONTINUE
  596.  1420    CONTINUE
  597.  1430 CONTINUE
  598.  
  599.       MCHPOI=IPO(2)
  600.       SEGACT MCHPOI
  601.       NSOUPO=IPCHP(/1)
  602.       DO 430 IA=1,NSOUPO
  603.          MSOUPO=IPCHP(IA)
  604.          SEGACT MSOUPO
  605.          MELEME=IGEOC
  606.          SEGACT MELEME
  607.          MPOVAL=IPOVAL
  608.          SEGACT MPOVAL
  609.          NBELEM=NUM(/2)
  610.          N=VPOCHA(/1)
  611.          NC=VPOCHA(/2)
  612.          NC1=NOCOMP(/2)
  613. C
  614.          DO 420 IB=1,NC1
  615.             DO 390 IC=1,NNIN
  616.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  617.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  618.  390        CONTINUE
  619.  400        CONTINUE
  620.             DO 410 ID=1,NBELEM
  621.                KI=NOPOIN(NUM(1,ID))
  622.                IGEO(KI)=NUM(1,ID)
  623.                IBIN(IC,KI)=1
  624.                BB(IC,KI)=BB(IC,KI)+XXT2*VPOCHA(ID,IB)
  625.  410        CONTINUE
  626.  420     CONTINUE
  627.  430  CONTINUE
  628.       ITRAV=MTRAV
  629. C
  630. C     RECONSTUCTION DE LA PARTITION
  631. C
  632.       CALL CRECHP(ITRAV,ICHPOI)
  633. C
  634.       SEGSUP MTRAV,MTRA,MTR1,MTR4
  635.       IRET   = ICHPOI
  636.       MCHPOI = ICHPOI
  637.       MCHPO1 = IPO1
  638.       MCHPO2 = IPO2
  639.       SEGACT MCHPO1,MCHPO2
  640.       NAT1 = MCHPO1.JATTRI(/1)
  641.       NAT2 = MCHPO2.JATTRI(/1)
  642.       NAT=MAX(NAT1,NAT2,1)
  643.       NSOUPO = IPCHP(/1)
  644.       SEGADJ,MCHPOI
  645.       IRET  =MCHPOI
  646.       MTYPOI=MOT
  647.       IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  648.          IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  649.             JATTRI(1)= MCHPO1.JATTRI(1)
  650.          ELSE
  651.             JATTRI(1)=0
  652.          ENDIF
  653.       ELSE
  654.          JATTRI(1)=0
  655.       ENDIF
  656.  
  657.       END
  658.  
  659.  
  660.  

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