Télécharger la plaquette Cast3M


fr en

Télécharger chame1.eso

Retour à la liste

Numérotation des lignes : 

chame1

  1. C CHAME1    SOURCE    PV090527  25/01/08    21:15:03     12111          
  2.  
  3. C____________________________________________________________________*
  4. C                                                                    *
  5. C     transformation de CHPOINT en MCHAML                            *
  6. C                                                                    *
  7. C     entrees:                                                       *
  8. C     ________                                                       *
  9. C                                                                    *
  10. C     ipmail       pointeur sur un maillage                          *
  11. C ou  ipmodl       pointeur sur un mmodel                            *
  12. C     ipchpo       pointeur sur le chpoint                           *
  13. C     cha          chaine de caractere contenant un sous type eventuel
  14. C     isup         indique le type de support demande :              *
  15. C                  1 le mchaml est laisse aux noeuds                 *
  16. C                  2 au centre de gravite                            *
  17. C                  3 aux points de gauss de la raideur               *
  18. C                  4 aux points de gauss de la masse                 *
  19. C                  5 aux points de gauss des contraintes             *
  20. C                  6 aux point de gauss de la thermique & diffusion  *
  21. C                    & metallurgie                                   *
  22. C                                                                    *
  23. C     sorties:                                                       *
  24. C     ________                                                       *
  25. C                                                                    *
  26. C     ipchel       pointeur sur le mchaml resultat                   *
  27. C                                                                    *
  28. C     Remarque : le passage du mchaml sur un autre support que les   *
  29. C     --------   noeuds n'est possible que si l'on a donne un mmodel *
  30. C                                                                    *
  31. C                le traitement d'harmoniques de fourier n'est pas    *
  32. C                implemente                                          *
  33. C                                                                    *
  34. C____________________________________________________________________*
  35. C                                                                    *
  36.       SUBROUTINE CHAME1(IPMAIL,IPMODL,IPCHPO,CHA,IPCHEL,ISUP)
  37.  
  38.       IMPLICIT INTEGER(I-N)
  39.       IMPLICIT REAL*8(A-H,O-Z)
  40.  
  41. -INC PPARAM
  42. -INC CCOPTIO
  43. -INC CCGEOME
  44. -INC CCASSIS
  45. -INC CCPRECO
  46. C==DEB= FORMULATION HHO == Include specifique ==========================
  47. -INC CCHHOPA
  48. C==FIN= FORMULATION HHO ================================================
  49.  
  50. -INC SMCHAML
  51. -INC SMCHPOI
  52. -INC SMINTE
  53. -INC SMMODEL
  54. -INC SMELEME
  55. -INC SMCOORD
  56.  
  57.       COMMON/cham1c/IPARA1,IPARA2
  58.       EXTERNAL CHAM1I
  59.       LOGICAL  BTHRD
  60.  
  61.       SEGMENT SPARA1
  62.         INTEGER NBTHR1
  63.         INTEGER IPCH1
  64.         INTEGER IPTP1
  65.         INTEGER IPTR1
  66.       ENDSEGMENT
  67.  
  68.       SEGMENT SPARA2
  69.         INTEGER NBTHRD
  70.         INTEGER IISUP
  71.         INTEGER IPSAU
  72.         INTEGER IPMOD
  73.         INTEGER IPCHE
  74.         INTEGER IPTPR
  75.         INTEGER IPTRA
  76.       ENDSEGMENT
  77.  
  78.       SEGMENT INFO
  79.         INTEGER INFELL(JG)
  80.       ENDSEGMENT
  81.  
  82.       SEGMENT ISAUT(IVAL,NSOUS)
  83.       SEGMENT ICPR(nbpts)
  84.  
  85.       SEGMENT MTRA2
  86. C      Copie du CHPOINT dans MTRA2 pour aller plus vite ensuite
  87.        CHARACTER*(LOCOMP) INCO(N2)
  88.        REAL*8      BB(NX,N2)
  89. C        INCO  : Nom des INCONNUES du CHPOINT
  90. C        BB    : Valeurs au noeuds du MMODEL (associees au ICPR)
  91. C                NX : Nombre de noeuds differents dans le MODELE
  92. C                N2 : Nombre de composantes dans le CHPOINT
  93.       ENDSEGMENT
  94.  
  95.       CHARACTER*(*) CHA
  96.       CHARACTER*(LOCOMP) MOCOMP
  97.       CHARACTER*1 MO1,VID1
  98.  
  99. C   soutyp = sous-type du champ par element resultat
  100. C   lsouty = longueur utile de la chaine "soutyp"
  101.       INTEGER LSOUTY
  102.       CHARACTER*72 SOUTYP
  103.       LOGICAL ICOQ
  104.  
  105.       if (isup.lt.1 .or. isup.gt.6) then
  106.         write(ioimp,*) 'CHAME1 : isup < 1 or isup > 6'
  107.         call erreur(5)
  108.       endif
  109.  
  110. c*      write(ioimp,*) 'chame1 ',ipmAIL,IPMODL,IPCHPO,CHA,ISUP
  111. *  preconditionnement on regarde si on a sauve le resultat
  112. *  on ne fait l'horodatage que pour le chp par mesure d'economie
  113.       ith=oothrd
  114.       call oooho1(ipmail,ihomai)
  115.       call oooho1(ipmodl,ihomod)
  116.       call oooho1(ipchpo,ihochp)
  117.       do 100 iprec=1,nprcha
  118.        if (iprma(iprec,ith).ne.ipmail) goto 100
  119.        if (iprhoa(iprec,ith).ne.ihomai) goto 100
  120.        if (iprmo(iprec,ith).ne.ipmodl) goto 100
  121.        if (iprhom(iprec,ith).ne.ihomod) goto 100
  122.        if (iprchp(iprec,ith).ne.ipchpo) goto 100
  123.        if (iprhoc(iprec,ith).ne.ihochp) goto 100
  124.        if (iprsu(iprec,ith).ne.isup  ) goto 100
  125.        if (iprcha(iprec,ith).ne.cha  ) goto 100
  126.        if (iprcnf(iprec,ith).ne.mcoord) goto 100
  127. *  preconditionnement trouve
  128.        ipchel=iprchl(iprec,ith)
  129. **     if(ith.eq.1)
  130. **   > write(6,*) ' preconditionnement trouve ',iprec,ith,ipchel
  131.        call actobj('MCHAML',ipchel,1)
  132.        return
  133.  100  continue
  134.  
  135.       IPARA1= 0
  136.       IPARA2= 0
  137.  
  138.       NT1   = 1
  139.       NT2   = 1
  140.       IOPTIM= 100
  141.  
  142.       INFO  = 0
  143.       IPCHEL= 0
  144.       VID1  = ' '
  145.       MO1   = ' '
  146.  
  147.       ither = 0
  148.       idiff = 0
  149.       imeta = 0
  150. C
  151. C   Informations sur le chpoint
  152. C
  153.       MCHPOI = IPCHPO
  154.  
  155. C     Renvoie le nombre de composantes
  156.       CALL NBCOMP(MCHPOI,'CHPOINT ',N2)
  157.  
  158.       NSOUPO = IPCHP(/1)
  159.  
  160.       ICOQ=.FALSE.
  161.       DO ISOUPO=1,NSOUPO
  162.         MSOUPO=IPCHP(ISOUPO)
  163.         NCOMPO=NOCOMP(/2)
  164.         DO ICO=1,NCOMPO
  165.           MOCOMP=MSOUPO.NOCOMP(ICO)
  166.           IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
  167.             ICOQ=.TRUE.
  168.             GOTO 1
  169.           ENDIF
  170.         ENDDO
  171.       ENDDO
  172.  1    CONTINUE
  173. C
  174. C     on cree l'objet maillage contenant tous les points du chpoint
  175.       IF (IPMAIL.NE.0) THEN
  176.          IPT1=IPMAIL
  177.          NSOU1 = IPT1.LISOUS(/1)
  178.          NSOUS = MAX(1,NSOU1)
  179.       ELSE IF (IPMODL.NE.0) THEN
  180.          MMODEL = IPMODL
  181.          NSOUS  = KMODEL(/1)
  182.       ENDIF
  183. C
  184. C     initialisation du segment descripteur du champ par element
  185. C
  186.       N1 = NSOUS
  187.       N3 = 6
  188.       MO1 = CHA(1:1)
  189.       IF (MO1.EQ.VID1) THEN
  190.          L1=8
  191.          SOUTYP=MTYPOI
  192.       ELSE
  193.          L1=LEN(CHA)
  194.          SOUTYP=CHA
  195.       ENDIF
  196.  
  197.       NX    =0
  198.  
  199. C     Dimensionnement de ISAUT
  200.       IVAL=6
  201.       IF (ICOQ) IVAL = IVAL + 2
  202.  
  203.       IF(OOTHRD .NE.0) call oooprl(1)
  204.       SEGINI,ICPR,ISAUT
  205.       IF(OOTHRD .NE.0) call oooprl(0)
  206.  
  207.       NSCHM = 0
  208.  
  209.       DO 19 ISOUS = 1, NSOUS
  210.  
  211.          IPMINT=0
  212.  
  213.          IF (IPMAIL.NE.0) THEN
  214.  
  215.             ISUP1 = 1
  216.  
  217.             IF (NSOU1.GE.1) THEN
  218.                IPT2=IPT1.LISOUS(ISOUS)
  219.             ELSE
  220.                IPT2=IPMAIL
  221.             ENDIF
  222.  
  223.          ELSE IF (IPMODL.NE.0) THEN
  224.  
  225.             ISUP1 = ISUP
  226.  
  227.             IMODEL = KMODEL(ISOUS)
  228.  
  229.             IPT2 = IMAMOD
  230.             MELE = NEFMOD
  231.  
  232. C==DEB= FORMULATION HHO ================================================
  233. C= On ne fait pas de MCHAML pour les HHO (a voir par la suite...)
  234.             IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  235.               GOTO 19
  236.             END IF
  237. C==FIN= FORMULATION HHO ================================================
  238.  
  239. c           pour les elements MULT, on autorise que les MCHAML aux noeuds
  240.             if (ISUP1.ne.1) then
  241.               if(mele.eq.22 .OR. mele.eq.259) goto 19
  242.             endif
  243.  
  244.             if (formod(1)(1:8).eq.'LIAISON ') then
  245. C             ne fait rien si le maillage de LIAISON n'appartient pas au CHPOINT
  246.  
  247.               IVAL1 = IPT2.num(1,1)
  248.               DO I=1,NSOUPO
  249.                 MSOUPO=IPCHP(I)
  250.                 MELEME=IGEOC
  251.                 do jno = 1, num(/2)
  252.                   if (num(1,jno).eq.IVAL1) goto 191
  253.                 enddo
  254.                 goto 19
  255.               ENDDO
  256.  191          CONTINUE
  257.             endif
  258.  
  259.             NPINT = INFMOD(1)
  260. C
  261. C           Changement de support si besoin selon la formulation ?
  262.             IF (ISUP1 .NE. 1) THEN
  263.               NFOR = FORMOD(/2)
  264.               CALL PLACE(FORMOD,NFOR,icont,'CONTACT         ')
  265.               CALL PLACE(FORMOD,NFOR,ichph,'CHANGEMENT_PHASE')
  266.               IF (icont.NE.0 .OR. ichph.NE.0) THEN
  267.                 ISUP1 = 1
  268.               ELSE
  269.                 CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
  270.                 CALL PLACE(FORMOD,NFOR,idiff,'DIFFUSION')
  271.                 CALL PLACE(FORMOD,NFOR,imeta,'METALLURGIE')
  272.                 IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  273.                   nmat = matmod(/2)
  274.                   CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  275. C                 Support 6 SAUF pour le RAYONNEMENT...
  276. C                 Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  277.                   IF (iray.EQ.0) THEN
  278.                     IF (ISUP1.GT.2) ISUP1 = 6
  279.                   ENDIF
  280.                 ENDIF
  281.               ENDIF
  282.             ENDIF
  283. C
  284. C           on recupere le pointeur sur le minte correspondant a isup1
  285. C
  286.             IF (ISUP1.GT.1) THEN
  287. C              cas de la THERMIQUE(sauf RAYONNEMENT) OU DIFFUSION OU METALLURGIE
  288.                IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  289.                  IF ( ISUP1 .EQ. 2) THEN
  290.                    CALL TSHAPE(MELE,'GRAVITE',IPMINT)
  291. cc                 ELSE IF ( ISUP1 .EQ. 6) THEN
  292.                  ELSE
  293.                    CALL TSHAPE(MELE,'GAUSS  ',IPMINT)
  294.                  ENDIF
  295.                  IF (IERR.NE.0) RETURN
  296.                  IELE = NUMGEO(MELE)
  297.                  NBNN = NBNNE(IELE)
  298.                ELSE
  299.                  if(2+isup1.gt.infmod(/1)) then
  300. c-dbg      write(ioimp,*) 'CHAME1 : cas 2+isup1  infmod(/1)'
  301.                    CALL ELQUOI(MELE,0,ISUP1,INFO,IMODEL)
  302.                    IF (IERR.NE.0) RETURN
  303.                    IPMINT=INFELL(11)
  304.                  else
  305.                    IPMINT=infmod(2+isup1)
  306.                    IELE  =INFELE(14)
  307.                    NBNN  =NBNNE(IELE)
  308.                  endif
  309.                ENDIF
  310. C
  311. C              initialisation de ipore pour milieu poreux
  312. C
  313.                IPORE=0
  314.                IF(MELE.GE.79 .AND.MELE.LE.83 ) IPORE=NBNN
  315.                IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
  316.                IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
  317. C              cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
  318. C*??               IF (MELE.EQ.263 .OR. MELE.EQ.264) IPORE=NBNN
  319.                IF (MELE.GE.263) IPORE=NBNN
  320.  
  321.                IF(IPORE .EQ. 0)THEN
  322.                  MINTE         =IPMINT
  323.                  ISAUT(5,ISOUS)=SHPTOT(/2)
  324.                ELSE
  325.                  ISAUT(5,ISOUS)=IPORE
  326.                ENDIF
  327.             ENDIF
  328. C
  329. C           Quels sont les modeles concernes par TINF et TSUP
  330.             IF (ICOQ) THEN
  331.               ISAUT(IVAL-1,ISOUS)=0
  332.               IPNOMC = 0
  333.               CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE')
  334.               IF (ITHER.NE.0) THEN
  335.                 IPNOMC = LNOMID(1)
  336.               ENDIF
  337.               CALL PLACE(FORMOD,NFOR,IMECA,'MECANIQUE')
  338.               IF (IMECA.NE.0) THEN
  339.                 IPNOMC = LNOMID(8)
  340.               ENDIF
  341.               IF (IPNOMC.EQ.0) GOTO 192
  342.               NOMID = IPNOMC
  343.               NCOBL = LESOBL(/2)
  344.               DO IJC = 1,NCOBL
  345.                 MOCOMP = LESOBL(IJC)
  346.                 IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
  347.                   ISAUT(IVAL-1,ISOUS)=1
  348.                   GOTO 192
  349.                 ENDIF
  350.               ENDDO
  351.  192          CONTINUE
  352.             ENDIF
  353. C
  354.          ELSE
  355.            CALL ERREUR(5)
  356.            RETURN
  357.          ENDIF
  358.  
  359.          NSCHM = NSCHM + 1
  360.  
  361.          NBNO = IPT2.NUM(/1)
  362.          N1EL = IPT2.NUM(/2)
  363.  
  364. C        Remplissage de l'ICPR a partir des noeuds du MMODEL
  365. C          L'utilisation d'un ICPR par MMODEL limite l'utilisation de
  366. C          memoire en parallele dans les ASSISTANTS
  367.          DO IEL=1,N1EL
  368.            DO INO=1,NBNO
  369.               INOEU=IPT2.NUM(INO,IEL)
  370.               IF(ICPR(INOEU) .EQ. 0)THEN
  371.                 NX=NX+1
  372.                 ICPR(INOEU)=NX
  373.               ENDIF
  374.            ENDDO
  375.          ENDDO
  376.  
  377.          IF(IPMINT .EQ. 0)THEN
  378.            N1PTEL=NBNO
  379.          ELSE
  380.            MINTE =IPMINT
  381.            N1PTEL=SHPTOT(/3)
  382.          ENDIF
  383.          NT2 = MAX(NT2,N1EL*N1PTEL)
  384.  
  385.          ISAUT(1,ISOUS) = IPT2
  386.          ISAUT(2,ISOUS) = N1EL
  387.          ISAUT(3,ISOUS) = N1PTEL
  388.          ISAUT(4,ISOUS) = IPMINT
  389.          ISAUT(6,ISOUS) = ISUP1
  390.  
  391.  19   CONTINUE
  392.  
  393. C     Creation d'un MAXIMUM de SEGMENTS dans un LOCK
  394.       N1 = NSCHM
  395.       IF(OOTHRD .NE.0) call oooprl(1)
  396.       SEGINI,MCHELM
  397.  
  398.       TITCHE=SOUTYP
  399.       IFOCHE=IFOUR
  400.  
  401.       N2PTEL=0
  402.       N2EL  =0
  403.  
  404.       ischm = 0
  405.       DO ISOUS = 1, NSOUS
  406.         IF (ISAUT(1,ISOUS).NE.0) THEN
  407.           ischm = ischm + 1
  408.           SEGINI,MCHAML
  409.           ICHAML(ischm) = MCHAML
  410.           N1EL   = ISAUT(2,ISOUS)
  411.           N1PTEL = ISAUT(3,ISOUS)
  412.           DO ICOMP=1,N2
  413.             SEGINI,MELVAL
  414.             IELVAL(ICOMP)=MELVAL
  415.           ENDDO
  416.           IF (ICOQ) THEN
  417.             IF (ISAUT(IVAL-1,ISOUS).EQ.1) THEN
  418.               SEGINI,MELVAL
  419.               ISAUT(IVAL,ISOUS) = MELVAL
  420.             ENDIF
  421.           ENDIF
  422.         ENDIF
  423.       ENDDO
  424.       IF (ischm.NE.NSCHM) THEN
  425.         write(ioimp,*) 'CHAME1 : Incompatibilite ischm & NSCHM'
  426.         CALL ERREUR(5)
  427.       ENDIF
  428.  
  429.       SEGINI,MTRA2
  430.       IF(OOTHRD .NE.0) call oooprl(0)
  431.  
  432.       NCO = 0
  433.       DO ISOUPO=1,NSOUPO
  434.         MSOUPO=IPCHP(ISOUPO)
  435.         MELEME=IGEOC
  436.         NT1   =MAX(NT1,NUM(/2))
  437.         NC    =MSOUPO.NOHARM(/1)
  438.         DO 101 ICO=1,NC
  439.           MOCOMP=MSOUPO.NOCOMP(ICO)
  440.           DO K=1,NCO
  441.             IF (MOCOMP .EQ. MTRA2.INCO(K)) GOTO 101
  442.           ENDDO
  443.           NCO = NCO + 1
  444.           K   = NCO
  445.           MTRA2.INCO(NCO)=MOCOMP
  446.  101    CONTINUE
  447.       ENDDO
  448.  
  449. C----------------------------------------------------------------------C
  450. C  Remplissage du MTRA2
  451. C----------------------------------------------------------------------C
  452.       NBTHR=MIN(MAX(NT1/IOPTIM,1),NBTHRS)
  453.       IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  454. C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  455. C                  DEJA DANS LES ASSISTANTS
  456.         NBTHR = 1
  457.         BTHRD = .FALSE.
  458.       ELSE
  459.         BTHRD = .TRUE.
  460.         CALL THREADII
  461.       ENDIF
  462.  
  463.       IF (BTHRD) THEN
  464. C       Remplissage du 'COMMON/cham1c'
  465.         SEGINI,SPARA1
  466.         IPARA1=SPARA1
  467.         IPARA2=0
  468.  
  469.         SPARA1.NBTHR1=NBTHR
  470.         SPARA1.IPCH1 =MCHPOI
  471.         SPARA1.IPTP1 =ICPR
  472.         SPARA1.IPTR1 =MTRA2
  473.  
  474.         DO ith=2,NBTHR
  475.           CALL THREADID(ith,CHAM1i)
  476.         ENDDO
  477.         CALL CHAM1i(1)
  478.  
  479. C       Attente de la fin de tous les threads en cours de travail
  480.         DO ith=2,NBTHR
  481.           CALL THREADIF(ith)
  482.         ENDDO
  483.  
  484. C       On libère les Threads
  485.         CALL THREADIS
  486.         SEGSUP,SPARA1
  487.  
  488.       ELSE
  489. C       Appel de la SUBROUTINE qui fait le travail
  490.         ith=1
  491.         CALL CHAM11(NBTHR,ith,MCHPOI,ICPR,MTRA2)
  492.       ENDIF
  493.  
  494. C----------------------------------------------------------------------C
  495. C  Remplissage du MCHAML
  496. C----------------------------------------------------------------------C
  497.  
  498.       NBTHR=MIN(MAX(NT2/IOPTIM,1),NBTHRS)
  499.       IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  500. C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  501. C                  DEJA DANS LES ASSISTANTS
  502.         NBTHR = 1
  503.         BTHRD = .FALSE.
  504.       ELSE
  505.         BTHRD = .TRUE.
  506.         CALL THREADII
  507.       ENDIF
  508.  
  509.       IF (BTHRD) THEN
  510. C       Remplissage du 'COMMON/cham1c'
  511.         SEGINI,SPARA2
  512.         IPARA1=0
  513.         IPARA2=SPARA2
  514.  
  515.         SPARA2.NBTHRD=NBTHR
  516.         SPARA2.IISUP =ISUP
  517.         SPARA2.IPSAU =ISAUT
  518.         SPARA2.IPMOD =IPMODL
  519.         SPARA2.IPCHE =MCHELM
  520.         SPARA2.IPTPR =ICPR
  521.         SPARA2.IPTRA =MTRA2
  522.  
  523.         DO ith=2,NBTHR
  524.           CALL THREADID(ith,CHAM1i)
  525.         ENDDO
  526.         CALL CHAM1i(1)
  527.  
  528. C       Attente de la fin de tous les threads en cours de travail
  529.         DO ith=2,NBTHR
  530.           CALL THREADIF(ith)
  531.         ENDDO
  532.  
  533. C       On libere les Threads
  534.         CALL THREADIS
  535.         SEGSUP,SPARA2
  536.  
  537.       ELSE
  538. C       Appel de la SUBROUTINE qui fait le travail
  539.         ith=1
  540.         CALL CHAM12(NBTHR,ith,ISUP,ISAUT,IPMODL,MCHELM,ICPR,MTRA2)
  541.       ENDIF
  542.  
  543. C     Modification pour les modeles avec TINF ou TSUP
  544.       IF (ICOQ.AND.IPMODL.NE.0) THEN
  545.         ischm = 0
  546.         DO ISOUS = 1, NSOUS
  547.           IF (ISAUT(1,ISOUS).NE.0) THEN
  548.             ischm = ischm + 1
  549.             IF (ISAUT(IVAL-1,ISOUS).EQ.2) THEN
  550.               MCHAM1 = ICHAML(ischm)
  551.               DO IJC = 1,N2
  552.                 MOCOMP = MCHAM1.NOMCHE(IJC)
  553.                 IF (MOCOMP.EQ.'T       ') GOTO 25
  554.               ENDDO
  555.  25           CONTINUE
  556.               MCHAM1.IELVAL(IJC)=ISAUT(IVAL,ISOUS)
  557.             ENDIF
  558.           ENDIF
  559.         ENDDO
  560.       ENDIF
  561. C
  562.       SEGSUP,MTRA2,ISAUT,ICPR
  563.       IF(INFO  .NE. 0)SEGSUP,INFO
  564.  
  565. C COMPACTAGE DU CHAMP OBTENU :
  566.       NSCHM = mchelm.ICHAML(/1)
  567.       DO ischm = 1, NSCHM
  568.         MCHAML = mchelm.ICHAML(ischm)
  569.         N2 = mchaml.IELVAL(/1)
  570.         DO ijc = 1, N2
  571.           MELVAL = mchaml.IELVAL(ijc)
  572.           IF (MELVAL .NE. 0) CALL COMRED(MELVAL)
  573.         ENDDO
  574.       ENDDO
  575.  
  576.       IPCHEL=MCHELM
  577. *  preconditionnement on garde l'operation en memoire
  578.       ith=oothrd
  579.       do iprec=nprcha,2,-1
  580.       iprma(iprec,ith) =iprma(iprec-1,ith)
  581.       iprhoa(iprec,ith)=iprhoa(iprec-1,ith)
  582.       iprmo(iprec,ith) =iprmo(iprec-1,ith)
  583.       iprhom(iprec,ith)=iprhom(iprec-1,ith)
  584.       iprchp(iprec,ith)=iprchp(iprec-1,ith)
  585.       iprhoc(iprec,ith)=iprhoc(iprec-1,ith)
  586.       iprsu(iprec,ith) =iprsu(iprec-1,ith)
  587.       iprcha(iprec,ith)=iprcha(iprec-1,ith)
  588.       iprcnf(iprec,ith)=iprcnf(iprec-1,ith)
  589.       iprchl(iprec,ith)=iprchl(iprec-1,ith)
  590.       enddo
  591.       iprma(1,ith) =ipmail
  592.       iprhoa(1,ith)=ihomai
  593.       iprmo(1,ith) =ipmodl
  594.       iprhom(1,ith)=ihomod
  595.       iprchp(1,ith)=ipchpo
  596.       iprhoc(1,ith)=ihochp
  597.       iprsu(1,ith) =isup
  598.       iprcha(1,ith)=cha
  599.       iprcnf(1,ith)=mcoord
  600.       iprchl(1,ith)=ipchel
  601. **    write(6,*) ' preconditionnement de ',ipchel
  602.  
  603.       END
  604.  
  605.  
  606.  
  607.  

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