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

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