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

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