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

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