Télécharger la plaquette Cast3M


fr en

Télécharger reduaf.eso

Retour à la liste

Numérotation des lignes : 

reduaf

  1. C REDUAF    SOURCE    PV090527  25/01/14    21:15:01     12111          
  2.  
  3. C  Reduction du champ par element jchelm sur le modele mmodtm
  4. C  Le resultat est le champ par element mchel2 pour iret = 1 (KERRE=0),
  5. C  sinon en cas d'erreur mchel2 = 0 pour iret = 0 (KERRE = num. erreur)
  6. C  En sortie le champ mchel2 est un champ entierement actif.
  7. C  (kich) en sortie mmodel deroule
  8.  
  9.       SUBROUTINE REDUAF (jchelm,mmodtm,mchel2,istri,iret,KERRE)
  10.  
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12.       IMPLICIT INTEGER (I-N)
  13.  
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17.  
  18. -INC SMCHAML
  19. -INC SMMODEL
  20.  
  21. -INC SMCOORD
  22. -INC SMELEME
  23. -INC SMLENTI
  24. -INC CCPRECO
  25. -INC CCASSIS
  26.  
  27.       EXTERNAL LONG
  28.  
  29.       segment izone(NZ,NSMOD)
  30.       segment ismel(NZ,NSMOD)
  31.       segment szsxx
  32.         logical lzsxx(NZ,NSMOD)
  33.       endsegment
  34.  
  35.       segment icpr(nbpt)
  36.       segment inde(jg)
  37.  
  38.       CHARACTER*(NCONCH) conloc,MO24
  39.       CHARACTER*(LOCOMP) nomloc
  40.       CHARACTER*(16)     typloc
  41.       CHARACTER*(50)     typ1
  42.  
  43.  
  44.       LOGICAL BVALID,OOOVP1,dmopa
  45.  
  46.       itconf=0
  47.       goto 10
  48. *
  49.       ENTRY REDUAG (jchelm,mmodtm,mchel2,istri,iret,KERRE)
  50.       itconf=1
  51.   10  continue
  52.       melpv = 0
  53.       ith1  = oothrd + 1
  54.  
  55. CG      if (iimpi.eq.7203) then
  56. CG        write(ioimp,*) 'Entree dans reduaf',mmodtm,jchelm
  57. CG        call zpchel(jchelm,1)
  58. CG      endif
  59. c       write(6,*) 'Entree dans reduaf',jchelm,istri,mmodtm
  60.       CALL oooho2(ihcour)
  61.       iret   = 1
  62.       KERRE  = 0
  63.       mchel2 = 0
  64.       MO24   =' '
  65.  
  66.       IF(istri     .EQ. 0)THEN
  67. C       Extension du MMODEL en cas de modele de MELANGE et NON-STRICT
  68.         CALL MODETE(mmodtm,mmodel,IMELAN)
  69.       ELSEIF(istri .EQ. 1)THEN
  70.         mmodel = mmodtm
  71.       ELSE
  72.         CALL ERREUR(5)
  73.       ENDIF
  74.  
  75.       NSMOD  = mmodel.kmodel(/1)
  76.       DO is = 1, NSMOD
  77.         imodel = mmodel.kmodel(is)
  78. C       Verification si on a un modele de DARCY actuellement incompatible
  79. C       Car il se servent du MAILLAGE dans la TABLE DOMAINE et pas celui
  80. C       contenu dans le MMODEL
  81.         CALL PLACE(imodel.FORMOD,imodel.FORMOD(/2),IDARC,'DARCY')
  82.         IF (IDARC .NE. 0) THEN
  83.           mchel2=jchelm
  84.           RETURN
  85.         ENDIF
  86.       ENDDO
  87. *  verif configuration
  88.       mchelm=jchelm
  89.       segact mchelm
  90.       mclcn=mclcnf
  91. *     write(6,*) 'reduaf mchelm mclcn',mchelm,mclcn
  92.       if (itconf.eq.0.and.mclcn .ne.0.and.mclcn .ne.mcoord
  93.      > .and.titche.ne.'CARACTERISTIQUES' ) then 
  94.        moterr(1:8) = 'CHAMELEM'
  95.        interr(1) = mclcn 
  96.        interr(2) = mcoord
  97.        interr(3) = mchelm
  98. **     call erreur(1149)
  99. **     return
  100.       endif
  101. C ---------------------------------------------------------------------
  102. C     Preconditionnement de REDU
  103. C     Verification que le resultat n'est pas deja dans le CCPRECO
  104. C ---------------------------------------------------------------------
  105.       ITAILL = NBPRRE(ith1)
  106.       itaill=0
  107.       CALL oooho1(mmodel,IHOmmo)
  108.       CALL oooho1(jchelm,IHOjch)
  109.       DO 201 IPREC1 = 1, ITAILL
  110.         IF  (PRECMO(IPREC1,ith1) .NE. mmodel)       GOTO 201
  111.         IF ((PRECM1(IPREC1,ith1) .NE. jchelm) .AND.
  112.      &      (PRECM2(IPREC1,ith1) .NE. jchelm))      GOTO 201
  113.         IF  (PRECM3(IPREC1,ith1) .NE. istri )       GOTO 201
  114.  
  115. C       Ajout test horodatage du MMODEL et MCHAML d'entree (il a pu etre supprime puis recree avec le meme descripteur)
  116.         IF  (PRECM4(IPREC1,ith1) .NE. IHOmmo)       GOTO 201
  117.         IF  (PRECM5(IPREC1,ith1) .NE. IHOjch)       GOTO 201
  118.         IF  (PRECM6(IPREC1,ith1) .NE. mclcn )       GOTO 201
  119.  
  120.         mchel2 = PRECM2(IPREC1,ith1)
  121.         segact mchel2
  122. *  il faut que le preconditionnement soit sur la bonne configuration
  123.         if(mchel2.mclcnf.ne.mclcn) then
  124.           mchel2 = 0
  125.           goto 201
  126.         endif
  127.         IF(mchel2 .NE. jchelm) CALL ACTOBJ('MCHAML  ',mchel2,1)
  128. C        IF (IPREC1 .EQ. NPREDU) THEN
  129. C          PRINT *,' CCPRECO trop petit :',IPREC1
  130. C          CALL ERREUR(5)
  131. C        ENDIF
  132.  
  133. C       Mise a jour du preconditionnement dans CCPRECO : Deplacement en position 1 du REDU deja fait
  134.         IF (IPREC1 .EQ. 1) THEN
  135.           RETURN
  136.         ELSE
  137.           DO IPREC2 = IPREC1,2,-1
  138.             PRECMO(IPREC2,ith1) = PRECMO(IPREC2 - 1,ith1)
  139.             PRECM1(IPREC2,ith1) = PRECM1(IPREC2 - 1,ith1)
  140.             PRECM2(IPREC2,ith1) = PRECM2(IPREC2 - 1,ith1)
  141.             PRECM3(IPREC2,ith1) = PRECM3(IPREC2 - 1,ith1)
  142.             PRECM4(IPREC2,ith1) = PRECM4(IPREC2 - 1,ith1)
  143.             PRECM5(IPREC2,ith1) = PRECM5(IPREC2 - 1,ith1)
  144.             PRECM6(IPREC2,ith1) = PRECM6(IPREC2 - 1,ith1)
  145.           ENDDO
  146.           PRECMO(1,ith1) = mmodel
  147.           PRECM1(1,ith1) = jchelm
  148.           PRECM2(1,ith1) = mchel2
  149.           PRECM3(1,ith1) = istri
  150.           PRECM4(1,ith1) = IHOmmo
  151.           PRECM5(1,ith1) = IHOjch
  152.           PRECM6(1,ith1) = mclcn 
  153.           RETURN
  154.         ENDIF
  155.  201  CONTINUE
  156.  
  157. C 1   CONTINUE
  158.  
  159. C     Mise a jour du preconditionnement dans CCPRECO : Deplacement pour ecrire le nouveau REDU en 1ere position
  160.       ITAILL       = MIN(ITAILL + 1, NPREDU)
  161.       NBPRRE(ith1) = ITAILL
  162.       DO IPRECO = ITAILL,2,-1
  163.         PRECMO(IPRECO,ith1) = PRECMO(IPRECO - 1,ith1)
  164.         PRECM1(IPRECO,ith1) = PRECM1(IPRECO - 1,ith1)
  165.         PRECM2(IPRECO,ith1) = PRECM2(IPRECO - 1,ith1)
  166.         PRECM3(IPRECO,ith1) = PRECM3(IPRECO - 1,ith1)
  167.         PRECM4(IPRECO,ith1) = PRECM4(IPRECO - 1,ith1)
  168.         PRECM5(IPRECO,ith1) = PRECM5(IPRECO - 1,ith1)
  169.         PRECM6(IPRECO,ith1) = PRECM6(IPRECO - 1,ith1)
  170.       ENDDO
  171.       PRECMO(1,ith1) = mmodel
  172.       PRECM1(1,ith1) = jchelm
  173. C     PRECM2 doit etre mis a jour plus loin avant chaque RETURN
  174.       PRECM3(1,ith1) = istri
  175.       PRECM4(1,ith1) = IHOmmo
  176.       PRECM5(1,ith1) = IHOjch
  177.       PRECM6(1,ith1) = mclcn  
  178.  
  179.       mchelm = jchelm
  180.       NZ = mchelm.imache(/1)
  181.       L1 = mchelm.titche(/1)
  182.       N3 = mchelm.infche(/2)
  183.  
  184. C -----------------------------------------
  185. C Cas tres particulier de MCHELM resultat :
  186. C -----------------------------------------
  187.       IF (NZ.EQ.0) THEN
  188. CG      if (iimpi.eq.7203) write(ioimp,*) 'CAS PARTICULIER NZ = 0'
  189. C       Mise a jour du preconditionnement dans CCPRECO
  190.         mchel2         = jchelm
  191.         PRECM2(1,ith1) = jchelm
  192.         RETURN
  193.       ENDIF
  194.  
  195. C     Quelques initialisations :
  196. C     mlent2 contient le nombre d'elements du maillage de chaque sous-modele.
  197.       jg = NSMOD
  198.       call oooprl(1)
  199.       SEGINI,mlent2,izone,ismel,szsxx
  200.  
  201. C     mlent3 contient les intersections entre les maillages determinees :
  202. C     mlent3.lect(i3) avec ismel(iz,is) = i3 correspond a l'intersection
  203. C     entre le maillage du sous-modele is et la sous-zone iz du champ si
  204. C     la valeur de i3 n'est pas nulle !
  205.  
  206.       jg = NSMOD * NZ
  207.       SEGINI,mlent3
  208.       call oooprl(0)
  209.       NL3 = 0
  210.       ISOZM = 0
  211.  
  212.       icpr = 0
  213.       inde = 0
  214. C
  215. C Regroupement des zones directement appariees avec un sous-modele
  216. C Recherche des zones pouvant intersecter le maillage d'un sous-modele
  217.  
  218.       CALL ACTOBJ('MCHAML  ',mchelm,1)
  219.       DO 100 is = 1, NSMOD
  220.         imodel = mmodel.kmodel(is)
  221.         IF (imodel.nefmod.EQ.259) GOTO 100
  222.         meleme = imodel.imamod
  223.         CALL oooho1(meleme,IHO1)
  224.         itypm = meleme.itypel
  225.         mlent2.lect(is) = meleme.num(/2)
  226. C On parcourt tous les NZ chamelem elementaires.
  227.         DO 101 iz = 1, NZ
  228.           conloc = mchelm.conche(iz)
  229.           lzsxx(iz,is) = .false.
  230.  
  231.           IF (conloc.NE.MO24 .AND.
  232.      &        conloc     .NE.imodel.conmod(1:LCONMO)) GOTO 101
  233. C         PRINT *,'REDUAF:',is,iz,':',conloc,':',imodel.conmod,':'
  234.           ixx = 0
  235.           ipt1 = mchelm.imache(iz)
  236. C Correspondance maillage sous-zone et sous-modele
  237.           IF (ipt1.EQ.meleme) THEN
  238.             ixx = 1
  239.             lzsxx(iz,is) = .true.
  240. C Pas de correspondance directe, recherche intersection potentielle
  241.           ELSE
  242.             IF (ipt1.itypel.NE.itypm) GOTO 102
  243.  
  244.             CALL oooho1(ipt1,IHO2)
  245. C           Verification dans le PRECONDITIONNEMENT si deja evaluee
  246.             DO 400 III=1,NINTSA(ith1)
  247.               IF(PMAMOD(III,ith1) .NE. meleme) GOTO 400
  248.               IF(PMAMOH(III,ith1) .NE. IHO1  ) GOTO 400
  249.               IF(PMACHA(III,ith1) .NE. ipt1  ) GOTO 400
  250.               IF(PMACHH(III,ith1) .NE. IHO2  ) GOTO 400
  251.               mlenti=PMLENT(III,ith1)
  252. C             PRINT *,'REDUAF_PRECONDITION',oothrd,meleme,ipt1,mlenti
  253.  
  254. C              IF(mlenti .EQ. 0) THEN
  255. C                ixx = 0
  256. C                ismel(iz,is) = 0
  257. C
  258. C              ELSE
  259.                 NL3 = NL3 + 1
  260.                 mlent3.lect(NL3) = mlenti
  261.                 ixx = -1
  262.                 ismel(iz,is) = NL3
  263. C              ENDIF
  264.               GOTO 102
  265.  400        CONTINUE
  266.  
  267. C            PRINT *,'REDUAF_INTERSECTION',oothrd,meleme,ipt1
  268.  
  269. C On va regarder si on n a pas deja evalue l'intersection :
  270. C (meme sous-modele is et sous-zone precedente ia<iz)
  271.             DO ia = 1, iz-1
  272.               IF (ipt1.EQ.mchelm.imache(ia)) THEN
  273.                 IF (ismel(ia,is).GT.0) THEN
  274.                   ixx = -2
  275.                   ismel(iz,is) = ismel(ia,is)
  276.                   GOTO 102
  277.                 ENDIF
  278.               ENDIF
  279.             ENDDO
  280. C (meme sous-zone iz et sous-modele ia<is)
  281.             DO 103 ia = 1, is-1
  282.               imode2 = mmodel.kmodel(ia)
  283.               IF (imode2.nefmod.EQ.259) GOTO 103
  284.               ipt2 = imode2.imamod
  285.               IF (ipt2.EQ.meleme) THEN
  286.                 IF (ismel(iz,ia).GT.0) THEN
  287.                   ixx = -3
  288.                   ismel(iz,is) = ismel(iz,ia)
  289.                   GOTO 102
  290.                 ENDIF
  291.               ENDIF
  292.  103        CONTINUE
  293.  
  294.  
  295. C           Détermination de l'intersection de ipt1 et meleme :
  296. C           Creation d'un tableau (LISTENTI) de correspondance des
  297. C           elements de IPT1 qui sont dans MELEME
  298.             nbno1 = ipt1.num(/1)
  299.             nbel1 = ipt1.num(/2)
  300.             IF (icpr.EQ.0) THEN
  301.               nbpt = nbpts + 1
  302.               np1 = nbpt - 1
  303.               SEGINI,icpr
  304.             ELSE
  305.               DO j = 1, nbpt
  306.                 icpr(j) = 0
  307.               ENDDO
  308.             ENDIF
  309.             DO j = 1, nbel1
  310.               DO m = 1, nbno1
  311.                 ib = ipt1.num(m,j)
  312.                 icpr(ib) = icpr(ib) + 1
  313.               ENDDO
  314.             ENDDO
  315.             iprec = icpr(1)
  316.             DO j = 2, np1
  317.               iprec = iprec + icpr(j)
  318.               icpr(j) = iprec
  319.             ENDDO
  320.             jg = icpr(np1)
  321.             icpr(nbpt) = jg
  322.             IF (inde.EQ.0) THEN
  323.               SEGINI,inde
  324.             ELSE
  325.               IF (jg.GT.inde(/1)) THEN
  326.                 SEGADJ,inde
  327.               ENDIF
  328.               DO j = 1, jg
  329.                 inde(j) = 0
  330.               ENDDO
  331.             ENDIF
  332.             DO j = 1, nbel1
  333.               DO m = 1, nbno1
  334.                 ib = ipt1.num(m,j)
  335.                 ia = icpr(ib)
  336.                 inde(ia) = j
  337.                 icpr(ib) = ia - 1
  338.               ENDDO
  339.             ENDDO
  340.  
  341.  
  342. C           Fin du travail preparatoire pour le maillage ipt1
  343.             ipt2 = imodel.imamod
  344.             nbno2 = ipt2.num(/1)
  345.             nbel2 = ipt2.num(/2)
  346. c*          ipt2 = imodel.imamod = meleme
  347. c*          nbno2 = ipt2.num(/1) = nbno1
  348. c*          nbel2 = ipt2.num(/2) = mlent2.lect(is)
  349.  
  350.  
  351. C           on fabrique le mlenti de correspondance
  352. C           on dimensionne au nombre d elements de ipt2 = sous-modele is
  353.             jg = nbel2
  354.             SEGINI,mlenti
  355.             ibon = 0
  356.             DO 110 iel2 = 1, nbel2
  357.               ia = ipt2.num(1,iel2)
  358.               ideb = icpr(ia)+1
  359.               ifin = icpr(ia+1)
  360.               IF (ifin.LT.ideb) GOTO 110
  361.               DO 111 ib = ideb, ifin
  362.                 iel1 = inde(ib)
  363.                 DO j = 1, nbno1
  364.                   IF (ipt2.num(j,iel2).NE.ipt1.num(j,iel1)) GOTO 111
  365.                 ENDDO
  366.                 ibon = ibon + 1
  367.                 mlenti.lect(iel2) = iel1
  368.                 GOTO 110
  369.  111          CONTINUE
  370.  110        CONTINUE
  371.  
  372.             IF (ibon .EQ. 0) THEN
  373. C             Intersection VIDE entre MELEME et IPT1
  374.               ixx = 0
  375.               ismel(iz,is) = 0
  376.               SEGSUP,mlenti
  377.  
  378.             ELSE
  379. C             Intersection NON VIDE entre MELEME et IPT1
  380.               IF (ibon.GT.nbel1) THEN
  381. C               Si on a plus d'elements dans l'intersection que dans ipt1 !
  382.                 write(ioimp,*) 'REDUAF : Etiquette 11x intersection ?'
  383.               ENDIF
  384.               NL3 = NL3 + 1
  385.               mlent3.lect(NL3) = mlenti
  386.               ixx = -1
  387.               ismel(iz,is) = NL3
  388.             ENDIF
  389.  
  390. C           Ajout dans le PRECONDITIONNEMENT : Ajout a la suite
  391.             IF(mlenti .NE. 0)THEN
  392.               IPLACE=MOD(NINTSA(ith1),MIN(NTRIPL,max(1,NBESCR)))+1
  393. C             PRINT *,'REDUAF_AJOUT',oothrd,IPLACE,meleme,ipt1,mlenti
  394.               PMAMOD(IPLACE,ith1) = meleme
  395.               PMAMOH(IPLACE,ith1) = IHO1
  396.               PMACHA(IPLACE,ith1) = ipt1
  397.               PMACHH(IPLACE,ith1) = IHO2
  398.               PMLENT(IPLACE,ith1) = mlenti
  399.               NINTSA(ith1)        = IPLACE
  400.             ENDIF
  401.           ENDIF
  402. CG        write(*,*) '       -',iz,is,ixx,ismel(iz,is)
  403.  
  404.  
  405.  102      CONTINUE
  406. C         Sous-zone du mchelm a traiter
  407.           IF (ixx .NE. 0) THEN
  408.             DO 105 ia = 1, iz-1
  409.               ib = izone(ia,is)
  410.               IF (ib.EQ.0) GOTO 105
  411.               IF (conche(ia)(1:NCONCH).NE.conloc) GOTO 105
  412.               DO k = 1, N3
  413.                 IF (k.NE.4) THEN
  414.                   IF (infche(ia,k).NE.infche(iz,k)) GOTO 105
  415.                 ENDIF
  416.               ENDDO
  417.               izone(iz,is) = ib
  418.               GOTO 106
  419.  105        CONTINUE
  420.             ISOZM = ISOZM + 1
  421.             izone(iz,is) = ISOZM
  422.  106        CONTINUE
  423.           ENDIF
  424. CG        write(*,*) '       -',iz,is,ixx,izone(iz,is)
  425.  101    CONTINUE
  426.  100  CONTINUE
  427.  
  428.       IF (icpr.NE.0) SEGSUP,icpr
  429.       IF (inde.NE.0) SEGSUP,inde
  430.  
  431.  
  432.  
  433.  
  434. C ---------------------------------
  435. C Construction du MCHELM resultat :
  436. C ---------------------------------
  437. C     Grace au traitement ci-dessus (boucle 105), ISOZM correspond a N1 :
  438.       N1 = ISOZM
  439.       L1 = mchelm.titche(/1)
  440.       N3 = mchelm.infche(/2)
  441.  
  442.       CALL oooprl(1)
  443.       SEGINI,mchel2
  444.       mchel2.titche = mchelm.titche
  445.       mchel2.ifoche = mchelm.ifoche
  446.  
  447. C Pour chaque sous-modele "is", on regroupe les sous-zones du mchelm "iz"
  448. C associees (izone(iz,is) > 0) :
  449.       DO 200 is = 1, NSMOD
  450.         imodel = kmodel(is)
  451.         IF (imodel.nefmod.EQ.259) GOTO 200
  452.         ipt2  = imodel.imamod
  453.         nbel2 = mlent2.lect(is)
  454.  
  455.         DO 210 iz = 1, NZ
  456.           in1 = izone(iz,is)
  457.           IF (in1.LE.0) GOTO 210
  458.           mchaml = mchelm.ichaml(iz)
  459.           n21 = mchaml.ielval(/1)
  460.  
  461. C         Cas particulier du mchaml sans composante (on ne fait rien) :
  462.           IF (n21.EQ.0) GOTO 210
  463.  
  464.           IF (mchel2.imache(in1).EQ.0) THEN
  465. CG            write(ioimp,*) '  Cas 1 :',mchel2.imache(in1)
  466.             mchel2.conche(in1) = mchelm.conche(iz)
  467.             mchel2.imache(in1) = ipt2
  468.             DO k = 1, N3
  469.               mchel2.infche(in1,k) = mchelm.infche(iz,k)
  470.             ENDDO
  471.             n22 = 0
  472.             n2 = n22 + n21
  473.             SEGINI,mcham2
  474.             mchel2.ichaml(in1) = mcham2
  475.           ELSE
  476. CG            write(ioimp,*) '  Cas 2 :',mchel2.imache(in1)
  477.             mcham2 = mchel2.ichaml(in1)
  478.             n22 = mcham2.ielval(/1)
  479.             n2 = n22 + n21
  480.             SEGADJ,mcham2
  481.           ENDIF
  482.  
  483. *jk148537
  484. **        if (lzsxx(iz,is)) then
  485. **          do i = 1,n21
  486. **             mcham2.nomche(n22+i) = mchaml.nomche(i)
  487. **             mcham2.typche(n22+i) = mchaml.typche(i)
  488. **             mcham2.ielval(n22+i) = mchaml.ielval(i)
  489. **          enddo
  490. **          goto 210
  491. **        endif 
  492.  
  493.           mlenti = ismel(iz,is)
  494.           IF (mlenti.GT.0) mlenti = mlent3.lect(mlenti)
  495. CG          write(ioimp,*) '        :',iz,is,mlenti,n22,n21,n2
  496.           DO i = 1, n21
  497.             nomloc = mchaml.nomche(i)
  498.             iplac = 0
  499.             IF (n22.NE.0) THEN
  500.               CALL PLACE(mcham2.nomche(1),n22,iplac,nomloc)
  501.             ENDIF
  502.             typloc = mchaml.typche(i)
  503.             melval = mchaml.ielval(i)
  504.             nbpi1 = MAX(melval.velche(/1),melval.ielche(/1))
  505.             nbel1 = MAX(melval.velche(/2),melval.ielche(/2))
  506.             IF (nbel1.GT.1) nbel1 = nbel2
  507.  
  508.             IF (iplac.EQ.0) THEN
  509.               iplac = n22 + i
  510.               mcham2.nomche(iplac) = nomloc
  511.               mcham2.typche(iplac) = typloc
  512.               IF (typloc.EQ.'REAL*8          ') THEN
  513.                 n1ptel = nbpi1
  514.                 n1el   = nbel2
  515.                 n2ptel = 0
  516.                 n2el   = 0
  517.               ELSE
  518.                 n1ptel = 0
  519.                 n1el   = 0
  520.                 n2ptel = nbpi1
  521.                 n2el   = nbel2
  522.               ENDIF
  523.  
  524.               SEGINI,melva2
  525.               if (n1ptel.eq.0.and.n2ptel.eq.0) then
  526. *                write(6,*) 'reduaf melva2 melval ',
  527. *     >                melva2,melval,n1ptel,n1el,n2ptel,n2el
  528.                 call erreur(5)
  529.               endif
  530.               mcham2.ielval(iplac) = melva2
  531.             ELSE
  532. C             incompatibilite du type de composante entre champs
  533.               IF (mcham2.typche(iplac).NE.typloc) THEN
  534.                 KERRE = 917
  535.                 MOTERR(1:4)   = nomloc
  536.                 MOTERR(5:21)  = typloc
  537.                 MOTERR(22:38) = mcham2.typche(iplac)
  538.                 call oooprl(0)
  539.                 GOTO 9000
  540.               ENDIF
  541.               melva2 = mcham2.ielval(iplac)
  542. *  on duplique melva2 au cas ou il soit partage car on va le modifier
  543. **            segini,melva3=melva2
  544. **            mcham2.ielval(iplac)=melva3
  545.             ENDIF
  546.               melva2 = mcham2.ielval(iplac)
  547.  
  548. C           On ajoute melval a melva2 en tenant compte de l'intersection entre
  549. C           les maillages (mlenti = 0 si maillage identique, >0 sinon)
  550. C          "Extension" de melva2 si besoin par rapport a melval (appel a MELEXT)
  551. C           sera effectuee en prealable de l'addition des valeurs dans MELADD.
  552. C    si melva2 existait avant, on le duplique avant de le modifier
  553.           CALL oooho1(melva2,ihmelv)
  554.           if (ihmelv.ne.ihcour) then
  555.            segini,melva3=melva2
  556.            melva2=melva3
  557.            mcham2.ielval(iplac)=melva2
  558.           endif  
  559.             CALL MELADD(melva2,melval,typloc,mlenti,KERRE)
  560.             IF (KERRE.NE.0) then
  561.               GOTO 9000
  562.               call oooprl(0)
  563.             endif
  564.           ENDDO
  565. C
  566.  210    CONTINUE
  567.  200  CONTINUE
  568.  
  569. C Compactage du champ resultat :
  570. C ------------------------------
  571.       n1max = n1
  572.       n1 = 0
  573.       DO 310 i = 1, n1max
  574.         mcham2 = mchel2.ichaml(i)
  575.         IF (mcham2.EQ.0) GOTO 310
  576. C on compacte les composantes (s'il y en a bien sur !)
  577.         n22 = mcham2.ielval(/1)
  578.         IF (n22.EQ.0) GOTO 312
  579.         n2 = 0
  580.         DO 311 j = 1, n22
  581.           melva2 = mcham2.ielval(j)
  582.           IF (melva2.EQ.0) GOTO 311
  583.           CALL oooho1(melva2,ihmelv)
  584.           IF(ihmelv .EQ. ihcour)THEN
  585. C           Reduction seulement pour les SEGMENTS nouveaux !
  586.             CALL COMRED(melva2)
  587.           ENDIF
  588.           segact melva2
  589.           n2 = n2 + 1
  590.           mcham2.nomche(n2) = mcham2.nomche(j)
  591.           mcham2.typche(n2) = mcham2.typche(j)
  592.           mcham2.ielval(n2) = melva2
  593.  311    CONTINUE
  594.         IF (n2.EQ.0) GOTO 310
  595.         IF (n2.NE.n22) SEGADJ,mcham2
  596.  312    CONTINUE
  597.         n1 = n1 + 1
  598.         mchel2.conche(n1) = mchel2.conche(i)
  599.         mchel2.imache(n1) = mchel2.imache(i)
  600.         mchel2.ichaml(n1) = mcham2
  601.  
  602.         DO j = 1, N3
  603.           mchel2.infche(n1,j) = mchel2.infche(i,j)
  604.         ENDDO
  605.  310  CONTINUE
  606.       IF (n1.NE.n1max) SEGADJ,mchel2
  607.       CALL oooprl(0)
  608.  
  609.  
  610. C     Definition du type du MCHAML
  611. C     typ1 contient le nom du type identifie
  612. C     ltyp1 la longueur de la chaine de caractere
  613. C
  614.       CALL TYPCHL(mchel2,mmodtm,typ1,ltyp1)
  615.       IF (IERR.NE.0) RETURN
  616. C     Cas particuliers des modeles de modele (melange)
  617.       IF(ltyp1.NE.-2 .AND. ltyp1.GT.0 .and. mchel2.titche.eq.' ')THEN
  618.          IF (ltyp1 .NE. L1 ) THEN
  619.            L1=ltyp1
  620.            SEGADJ, mchel2
  621.          ENDIF
  622.          mchel2.titche=typ1
  623.       ENDIF
  624. C On sort un champ vide s'il n'y a pas de zone commune :
  625. c*      IF (n1.EQ.0) THEN
  626. c**G        if (iimpi.eq.7203) write(ioimp,*) 'N1 = 0 apres traitement'
  627. c*        KERRE = 21
  628. c*      ENDIF
  629.  
  630.  9000 CONTINUE
  631. C Destruction des segments de travail devenus inutiles :
  632.       SEGSUP,izone,ismel,mlent3,mlent2,szsxx
  633.  
  634.  9010 CONTINUE
  635.       IF (KERRE.NE.0) THEN
  636.         iret = 0
  637.         mchel2 = 0
  638.       ENDIF
  639.  
  640. CG    if (iimpi.eq.7203) then
  641. CG    write(ioimp,*) 'Sortie de reduaf',mchel2,kerre
  642. CG      if (kerre.eq.0) call zpchel(mchel2,1)
  643. CG    endif
  644.  
  645. C     Mise a jour du preconditionnement dans CCPRECO (Nouveau champ mchel2)
  646. ***   CALL ACTOBJ('MCHAML  ',mchel2,1)
  647.       PRECM2(1,ith1) = mchel2
  648.  
  649.       END
  650.  
  651.  
  652.  
  653.  
  654.  
  655.  

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