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    OF166741  24/10/21    21:15:05     12042          
  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. *  preconditionnement trouve
  127.        ipchel=iprchl(iprec,ith)
  128. **     if(ith.eq.1)
  129. **   > write(6,*) ' preconditionnement trouve ',iprec,ith,ipchel
  130.        call actobj('MCHAML',ipchel,1)
  131.        return
  132.  100  continue
  133.  
  134.       IPARA1= 0
  135.       IPARA2= 0
  136.  
  137.       NT1   = 1
  138.       NT2   = 1
  139.       IOPTIM= 100
  140.  
  141.       INFO  = 0
  142.       IPCHEL= 0
  143.       VID1  = ' '
  144.       MO1   = ' '
  145.  
  146.       ither = 0
  147.       idiff = 0
  148.       imeta = 0
  149. C
  150. C   Informations sur le chpoint
  151. C
  152.       MCHPOI = IPCHPO
  153.  
  154. C     Renvoie le nombre de composantes
  155.       CALL NBCOMP(MCHPOI,'CHPOINT ',N2)
  156.  
  157.       NSOUPO = IPCHP(/1)
  158.  
  159.       ICOQ=.FALSE.
  160.       DO ISOUPO=1,NSOUPO
  161.         MSOUPO=IPCHP(ISOUPO)
  162.         NCOMPO=NOCOMP(/2)
  163.         DO ICO=1,NCOMPO
  164.           MOCOMP=MSOUPO.NOCOMP(ICO)
  165.           IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
  166.             ICOQ=.TRUE.
  167.             GOTO 1
  168.           ENDIF
  169.         ENDDO
  170.       ENDDO
  171.  1    CONTINUE
  172. C
  173. C     on cree l'objet maillage contenant tous les points du chpoint
  174.       IF (IPMAIL.NE.0) THEN
  175.          IPT1=IPMAIL
  176.          NSOU1 = IPT1.LISOUS(/1)
  177.          NSOUS = MAX(1,NSOU1)
  178.       ELSE IF (IPMODL.NE.0) THEN
  179.          MMODEL = IPMODL
  180.          NSOUS  = KMODEL(/1)
  181.       ENDIF
  182. C
  183. C     initialisation du segment descripteur du champ par element
  184. C
  185.       N1 = NSOUS
  186.       N3 = 6
  187.       MO1 = CHA(1:1)
  188.       IF (MO1.EQ.VID1) THEN
  189.          L1=8
  190.          SOUTYP=MTYPOI
  191.       ELSE
  192.          L1=LEN(CHA)
  193.          SOUTYP=CHA
  194.       ENDIF
  195.  
  196.       NX    =0
  197.  
  198. C     Dimensionnement de ISAUT
  199.       IVAL=6
  200.       IF (ICOQ) IVAL = IVAL + 2
  201.  
  202.       IF(OOTHRD .NE.0) call oooprl(1)
  203.       SEGINI,ICPR,ISAUT
  204.       IF(OOTHRD .NE.0) call oooprl(0)
  205.  
  206.       NSCHM = 0
  207.  
  208.       DO 19 ISOUS = 1, NSOUS
  209.  
  210.          IPMINT=0
  211.  
  212.          IF (IPMAIL.NE.0) THEN
  213.  
  214.             ISUP1 = 1
  215.  
  216.             IF (NSOU1.GE.1) THEN
  217.                IPT2=IPT1.LISOUS(ISOUS)
  218.             ELSE
  219.                IPT2=IPMAIL
  220.             ENDIF
  221.  
  222.          ELSE IF (IPMODL.NE.0) THEN
  223.  
  224.             ISUP1 = ISUP
  225.  
  226.             IMODEL = KMODEL(ISOUS)
  227.  
  228.             IPT2 = IMAMOD
  229.             MELE = NEFMOD
  230.  
  231. C==DEB= FORMULATION HHO ================================================
  232. C= On ne fait pas de MCHAML pour les HHO (a voir par la suite...)
  233.             IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  234.               GOTO 19
  235.             END IF
  236. C==FIN= FORMULATION HHO ================================================
  237.  
  238. c           pour les elements MULT, on autorise que les MCHAML aux noeuds
  239.             if (ISUP1.ne.1) then
  240.               if(mele.eq.22 .OR. mele.eq.259) goto 19
  241.             endif
  242.  
  243.             if (formod(1)(1:8).eq.'LIAISON ') then
  244. C             ne fait rien si le maillage de LIAISON n'appartient pas au CHPOINT
  245.  
  246.               IVAL1 = IPT2.num(1,1)
  247.               DO I=1,NSOUPO
  248.                 MSOUPO=IPCHP(I)
  249.                 MELEME=IGEOC
  250.                 do jno = 1, num(/2)
  251.                   if (num(1,jno).eq.IVAL1) goto 191
  252.                 enddo
  253.                 goto 19
  254.               ENDDO
  255.  191          CONTINUE
  256.             endif
  257.  
  258.             NPINT = INFMOD(1)
  259. C
  260. C           Changement de support si besoin selon la formulation ?
  261.             IF (ISUP1 .NE. 1) THEN
  262.               NFOR = FORMOD(/2)
  263.               CALL PLACE(FORMOD,NFOR,icont,'CONTACT         ')
  264.               CALL PLACE(FORMOD,NFOR,ichph,'CHANGEMENT_PHASE')
  265.               IF (icont.NE.0 .OR. ichph.NE.0) THEN
  266.                 ISUP1 = 1
  267.               ELSE
  268.                 CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
  269.                 CALL PLACE(FORMOD,NFOR,idiff,'DIFFUSION')
  270.                 CALL PLACE(FORMOD,NFOR,imeta,'METALLURGIE')
  271.                 IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  272.                   nmat = matmod(/2)
  273.                   CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  274. C                 Support 6 SAUF pour le RAYONNEMENT...
  275. C                 Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  276.                   IF (iray.EQ.0) THEN
  277.                     IF (ISUP1.GT.2) ISUP1 = 6
  278.                   ENDIF
  279.                 ENDIF
  280.               ENDIF
  281.             ENDIF
  282. C
  283. C           on recupere le pointeur sur le minte correspondant a isup1
  284. C
  285.             IF (ISUP1.GT.1) THEN
  286. C              cas de la THERMIQUE(sauf RAYONNEMENT) OU DIFFUSION OU METALLURGIE
  287.                IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  288.                  IF ( ISUP1 .EQ. 2) THEN
  289.                    CALL TSHAPE(MELE,'GRAVITE',IPMINT)
  290. cc                 ELSE IF ( ISUP1 .EQ. 6) THEN
  291.                  ELSE
  292.                    CALL TSHAPE(MELE,'GAUSS  ',IPMINT)
  293.                  ENDIF
  294.                  IF (IERR.NE.0) RETURN
  295.                  IELE = NUMGEO(MELE)
  296.                  NBNN = NBNNE(IELE)
  297.                ELSE
  298.                  if(2+isup1.gt.infmod(/1)) then
  299. c-dbg      write(ioimp,*) 'CHAME1 : cas 2+isup1  infmod(/1)'
  300.                    CALL ELQUOI(MELE,0,ISUP1,INFO,IMODEL)
  301.                    IF (IERR.NE.0) RETURN
  302.                    IPMINT=INFELL(11)
  303.                  else
  304.                    IPMINT=infmod(2+isup1)
  305.                    IELE  =INFELE(14)
  306.                    NBNN  =NBNNE(IELE)
  307.                  endif
  308.                ENDIF
  309. C
  310. C              initialisation de ipore pour milieu poreux
  311. C
  312.                IPORE=0
  313.                IF(MELE.GE.79 .AND.MELE.LE.83 ) IPORE=NBNN
  314.                IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
  315.                IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
  316. C              cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
  317. C*??               IF (MELE.EQ.263 .OR. MELE.EQ.264) IPORE=NBNN
  318.                IF (MELE.GE.263) IPORE=NBNN
  319.  
  320.                IF(IPORE .EQ. 0)THEN
  321.                  MINTE         =IPMINT
  322.                  ISAUT(5,ISOUS)=SHPTOT(/2)
  323.                ELSE
  324.                  ISAUT(5,ISOUS)=IPORE
  325.                ENDIF
  326.             ENDIF
  327. C
  328. C           Quels sont les modeles concernes par TINF et TSUP
  329.             IF (ICOQ) THEN
  330.               ISAUT(IVAL-1,ISOUS)=0
  331.               IPNOMC = 0
  332.               CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE')
  333.               IF (ITHER.NE.0) THEN
  334.                 IPNOMC = LNOMID(1)
  335.               ENDIF
  336.               CALL PLACE(FORMOD,NFOR,IMECA,'MECANIQUE')
  337.               IF (IMECA.NE.0) THEN
  338.                 IPNOMC = LNOMID(8)
  339.               ENDIF
  340.               IF (IPNOMC.EQ.0) GOTO 192
  341.               NOMID = IPNOMC
  342.               NCOBL = LESOBL(/2)
  343.               DO IJC = 1,NCOBL
  344.                 MOCOMP = LESOBL(IJC)
  345.                 IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
  346.                   ISAUT(IVAL-1,ISOUS)=1
  347.                   GOTO 192
  348.                 ENDIF
  349.               ENDDO
  350.  192          CONTINUE
  351.             ENDIF
  352. C
  353.          ELSE
  354.            CALL ERREUR(5)
  355.            RETURN
  356.          ENDIF
  357.  
  358.          NSCHM = NSCHM + 1
  359.  
  360.          NBNO = IPT2.NUM(/1)
  361.          N1EL = IPT2.NUM(/2)
  362.  
  363. C        Remplissage de l'ICPR a partir des noeuds du MMODEL
  364. C          L'utilisation d'un ICPR par MMODEL limite l'utilisation de
  365. C          memoire en parallele dans les ASSISTANTS
  366.          DO IEL=1,N1EL
  367.            DO INO=1,NBNO
  368.               INOEU=IPT2.NUM(INO,IEL)
  369.               IF(ICPR(INOEU) .EQ. 0)THEN
  370.                 NX=NX+1
  371.                 ICPR(INOEU)=NX
  372.               ENDIF
  373.            ENDDO
  374.          ENDDO
  375.  
  376.          IF(IPMINT .EQ. 0)THEN
  377.            N1PTEL=NBNO
  378.          ELSE
  379.            MINTE =IPMINT
  380.            N1PTEL=SHPTOT(/3)
  381.          ENDIF
  382.          NT2 = MAX(NT2,N1EL*N1PTEL)
  383.  
  384.          ISAUT(1,ISOUS) = IPT2
  385.          ISAUT(2,ISOUS) = N1EL
  386.          ISAUT(3,ISOUS) = N1PTEL
  387.          ISAUT(4,ISOUS) = IPMINT
  388.          ISAUT(6,ISOUS) = ISUP1
  389.  
  390.  19   CONTINUE
  391.  
  392. C     Creation d'un MAXIMUM de SEGMENTS dans un LOCK
  393.       N1 = NSCHM
  394.       IF(OOTHRD .NE.0) call oooprl(1)
  395.       SEGINI,MCHELM
  396.  
  397.       TITCHE=SOUTYP
  398.       IFOCHE=IFOUR
  399.  
  400.       N2PTEL=0
  401.       N2EL  =0
  402.  
  403.       ischm = 0
  404.       DO ISOUS = 1, NSOUS
  405.         IF (ISAUT(1,ISOUS).NE.0) THEN
  406.           ischm = ischm + 1
  407.           SEGINI,MCHAML
  408.           ICHAML(ischm) = MCHAML
  409.           N1EL   = ISAUT(2,ISOUS)
  410.           N1PTEL = ISAUT(3,ISOUS)
  411.           DO ICOMP=1,N2
  412.             SEGINI,MELVAL
  413.             IELVAL(ICOMP)=MELVAL
  414.           ENDDO
  415.           IF (ICOQ) THEN
  416.             IF (ISAUT(IVAL-1,ISOUS).EQ.1) THEN
  417.               SEGINI,MELVAL
  418.               ISAUT(IVAL,ISOUS) = MELVAL
  419.             ENDIF
  420.           ENDIF
  421.         ENDIF
  422.       ENDDO
  423.       IF (ischm.NE.NSCHM) THEN
  424.         write(ioimp,*) 'CHAME1 : Incompatibilite ischm & NSCHM'
  425.         CALL ERREUR(5)
  426.       ENDIF
  427.  
  428.       SEGINI,MTRA2
  429.       IF(OOTHRD .NE.0) call oooprl(0)
  430.  
  431.       NCO = 0
  432.       DO ISOUPO=1,NSOUPO
  433.         MSOUPO=IPCHP(ISOUPO)
  434.         MELEME=IGEOC
  435.         NT1   =MAX(NT1,NUM(/2))
  436.         NC    =MSOUPO.NOHARM(/1)
  437.         DO 101 ICO=1,NC
  438.           MOCOMP=MSOUPO.NOCOMP(ICO)
  439.           DO K=1,NCO
  440.             IF (MOCOMP .EQ. MTRA2.INCO(K)) GOTO 101
  441.           ENDDO
  442.           NCO = NCO + 1
  443.           K   = NCO
  444.           MTRA2.INCO(NCO)=MOCOMP
  445.  101    CONTINUE
  446.       ENDDO
  447.  
  448. C----------------------------------------------------------------------C
  449. C  Remplissage du MTRA2
  450. C----------------------------------------------------------------------C
  451.       NBTHR=MIN(MAX(NT1/IOPTIM,1),NBTHRS)
  452.       IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  453. C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  454. C                  DEJA DANS LES ASSISTANTS
  455.         NBTHR = 1
  456.         BTHRD = .FALSE.
  457.       ELSE
  458.         BTHRD = .TRUE.
  459.         CALL THREADII
  460.       ENDIF
  461.  
  462.       IF (BTHRD) THEN
  463. C       Remplissage du 'COMMON/cham1c'
  464.         SEGINI,SPARA1
  465.         IPARA1=SPARA1
  466.         IPARA2=0
  467.  
  468.         SPARA1.NBTHR1=NBTHR
  469.         SPARA1.IPCH1 =MCHPOI
  470.         SPARA1.IPTP1 =ICPR
  471.         SPARA1.IPTR1 =MTRA2
  472.  
  473.         DO ith=2,NBTHR
  474.           CALL THREADID(ith,CHAM1i)
  475.         ENDDO
  476.         CALL CHAM1i(1)
  477.  
  478. C       Attente de la fin de tous les threads en cours de travail
  479.         DO ith=2,NBTHR
  480.           CALL THREADIF(ith)
  481.         ENDDO
  482.  
  483. C       On libère les Threads
  484.         CALL THREADIS
  485.         SEGSUP,SPARA1
  486.  
  487.       ELSE
  488. C       Appel de la SUBROUTINE qui fait le travail
  489.         ith=1
  490.         CALL CHAM11(NBTHR,ith,MCHPOI,ICPR,MTRA2)
  491.       ENDIF
  492.  
  493. C----------------------------------------------------------------------C
  494. C  Remplissage du MCHAML
  495. C----------------------------------------------------------------------C
  496.  
  497.       NBTHR=MIN(MAX(NT2/IOPTIM,1),NBTHRS)
  498.       IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  499. C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  500. C                  DEJA DANS LES ASSISTANTS
  501.         NBTHR = 1
  502.         BTHRD = .FALSE.
  503.       ELSE
  504.         BTHRD = .TRUE.
  505.         CALL THREADII
  506.       ENDIF
  507.  
  508.       IF (BTHRD) THEN
  509. C       Remplissage du 'COMMON/cham1c'
  510.         SEGINI,SPARA2
  511.         IPARA1=0
  512.         IPARA2=SPARA2
  513.  
  514.         SPARA2.NBTHRD=NBTHR
  515.         SPARA2.IISUP =ISUP
  516.         SPARA2.IPSAU =ISAUT
  517.         SPARA2.IPMOD =IPMODL
  518.         SPARA2.IPCHE =MCHELM
  519.         SPARA2.IPTPR =ICPR
  520.         SPARA2.IPTRA =MTRA2
  521.  
  522.         DO ith=2,NBTHR
  523.           CALL THREADID(ith,CHAM1i)
  524.         ENDDO
  525.         CALL CHAM1i(1)
  526.  
  527. C       Attente de la fin de tous les threads en cours de travail
  528.         DO ith=2,NBTHR
  529.           CALL THREADIF(ith)
  530.         ENDDO
  531.  
  532. C       On libere les Threads
  533.         CALL THREADIS
  534.         SEGSUP,SPARA2
  535.  
  536.       ELSE
  537. C       Appel de la SUBROUTINE qui fait le travail
  538.         ith=1
  539.         CALL CHAM12(NBTHR,ith,ISUP,ISAUT,IPMODL,MCHELM,ICPR,MTRA2)
  540.       ENDIF
  541.  
  542. C     Modification pour les modeles avec TINF ou TSUP
  543.       IF (ICOQ.AND.IPMODL.NE.0) THEN
  544.         ischm = 0
  545.         DO ISOUS = 1, NSOUS
  546.           IF (ISAUT(1,ISOUS).NE.0) THEN
  547.             ischm = ischm + 1
  548.             IF (ISAUT(IVAL-1,ISOUS).EQ.2) THEN
  549.               MCHAM1 = ICHAML(ischm)
  550.               DO IJC = 1,N2
  551.                 MOCOMP = MCHAM1.NOMCHE(IJC)
  552.                 IF (MOCOMP.EQ.'T       ') GOTO 25
  553.               ENDDO
  554.  25           CONTINUE
  555.               MCHAM1.IELVAL(IJC)=ISAUT(IVAL,ISOUS)
  556.             ENDIF
  557.           ENDIF
  558.         ENDDO
  559.       ENDIF
  560. C
  561.       SEGSUP,MTRA2,ISAUT,ICPR
  562.       IF(INFO  .NE. 0)SEGSUP,INFO
  563.  
  564. C COMPACTAGE DU CHAMP OBTENU :
  565.       NSCHM = mchelm.ICHAML(/1)
  566.       DO ischm = 1, NSCHM
  567.         MCHAML = mchelm.ICHAML(ischm)
  568.         N2 = mchaml.IELVAL(/1)
  569.         DO ijc = 1, N2
  570.           MELVAL = mchaml.IELVAL(ijc)
  571.           IF (MELVAL .NE. 0) CALL COMRED(MELVAL)
  572.         ENDDO
  573.       ENDDO
  574.  
  575.       IPCHEL=MCHELM
  576. *  preconditionnement on garde l'operation en memoire
  577.       ith=oothrd
  578.       do iprec=nprcha,2,-1
  579.       iprma(iprec,ith) =iprma(iprec-1,ith)
  580.       iprhoa(iprec,ith)=iprhoa(iprec-1,ith)
  581.       iprmo(iprec,ith) =iprmo(iprec-1,ith)
  582.       iprhom(iprec,ith)=iprhom(iprec-1,ith)
  583.       iprchp(iprec,ith)=iprchp(iprec-1,ith)
  584.       iprhoc(iprec,ith)=iprhoc(iprec-1,ith)
  585.       iprsu(iprec,ith) =iprsu(iprec-1,ith)
  586.       iprcha(iprec,ith)=iprcha(iprec-1,ith)
  587.       iprchl(iprec,ith)=iprchl(iprec-1,ith)
  588.       enddo
  589.       iprma(1,ith) =ipmail
  590.       iprhoa(1,ith)=ihomai
  591.       iprmo(1,ith) =ipmodl
  592.       iprhom(1,ith)=ihomod
  593.       iprchp(1,ith)=ipchpo
  594.       iprhoc(1,ith)=ihochp
  595.       iprsu(1,ith) =isup
  596.       iprcha(1,ith)=cha
  597.       iprchl(1,ith)=ipchel
  598. **    write(6,*) ' preconditionnement de ',ipchel
  599.  
  600.       END
  601.  
  602.  
  603.  

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