Télécharger la plaquette Cast3M


fr en

Télécharger tassp2.eso

Retour à la liste

Numérotation des lignes : 

tassp2

  1. C TASSP2    SOURCE    OF166741  26/03/11    21:15:05     12493          
  2.  
  3.       SUBROUTINE TASSP2(ITLAC1,ICPR,ICDOUR,ICOLAC,mena,idonn)
  4. C======================================================================
  5. C   CE SOUS PROGRAMME EST APPELE PAR TASSPO ELIMIN OU CONFON
  6. C
  7. C   itlac1 est une liste de pointeurs sur les maillages arguments
  8. C   icpr etablit une correspondance entre la numerotation globale
  9. C        des noeuds et une numerotation locale qui tient compte de
  10. C        l'elimination
  11. C   icdour est le max des valeurs de icpr
  12. C
  13. C  MODIF OCTOBRE 1988 PAR PV  TRAITE TOUS LES MELEME
  14. C  QUE SAUVER SAIT TRAITER
  15. C=====================================================================
  16.       implicit integer (i-n)
  17.       implicit real*8(a-h,o-z)
  18.  
  19.       integer I, I1, I2, I3, IA, IB
  20.       integer ICDOUR, mena
  21.       integer ICHPOI, ICOMPT
  22.       integer IGE, ILG, IMA, IN, IOB, IOU, IP,IPILE, IPREME
  23.       integer IRATT, ITL, J, JJ, K, LCONMO, NAL1, NAL2
  24.       integer NBEMEL, NBNNAC, NBNNPR, NCONCH, NPM, NSOUPO
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC COCOLL
  29. -INC CCNOYAU
  30. -INC CCGEOME
  31. -INC CCPRECO
  32. -INC CCASSIS
  33. C==DEB= FORMULATION HHO == Donnees globales ============================
  34. -INC CCHHOPA
  35. -INC CCHHOPR
  36. C==FIN= FORMULATION HHO ================================================
  37.  
  38. -INC SMELEME
  39. -INC SMCOORD
  40. -INC SMTABLE
  41. -INC SMCHAML
  42. -INC TMLCHA8
  43. -INC SMCHPOI
  44. -INC SMNUAGE
  45. -INC TMCOLAC
  46. -INC SMLOBJE
  47.  
  48.       SEGMENT TAB1
  49.         REAL*8 XCOOR1(ILG)
  50.       ENDSEGMENT
  51.       SEGMENT TAB2
  52.         REAL*8 RCOOR1(idim,icdour)
  53.       ENDSEGMENT
  54.       SEGMENT icpr(0)
  55.       segment idcp(icdour)
  56.       SEGMENT ITRAV(NPM)
  57.       segment itrav2(nbpts)
  58.  
  59. C     Piles de communication MPI
  60.       pointeur piles.LISPIL
  61.       pointeur jcolac.ICOLAC
  62.       pointeur jlisse.ILISSE
  63.       pointeur jtlacc.ITLACC
  64.       pointeur pile.ITLACC
  65. C
  66.       CHARACTER*8 TYPE
  67. C      LOGICAL FLAG
  68.       DATA NBNNPR/0/
  69. C=====================================================================
  70.       iun=1
  71.       TYPE=' '
  72.       K=-1
  73. C     on recupere dans k  -npossi, le nombre de type objet possibles
  74.       CALL TYPFIL(TYPE,K)
  75. C     la pile icolac est cree
  76.       CALL CREPIL(ICOLAC,-K)
  77.       SEGACT ICOLAC*MOD
  78.       ITLACC=KCOLA(1)
  79.       ILISSE=ILISSG
  80.       segact ilisse*mod
  81.       IF (ITLAC1.NE.0) THEN
  82.          SEGSUP ITLACC
  83.          KCOLA(1)=ITLAC1
  84.          ITLACC=KCOLA(1)
  85. C il faut initialiser ilisse sinon on retrouve deux fois les segments
  86.          DO 5468 K=1,ITLAC(/1)
  87.            IA=ITLAC(K)
  88.            IF(IA.EQ.0) GO TO 5468
  89.            ILISEG((IA-1)/npgcd)=K
  90.  5468    CONTINUE
  91.       ENDIF
  92. C initialisation avec les maillages preconditionnees
  93.       do 145 ith=0,nbesc
  94.       do ip=1,nbemel
  95.        ipreme= premel(ip,ith)
  96.        if (ipreme.ne.0) then
  97.         call ajoun(itlacc,ipreme,ilisse,iun)
  98.        else
  99.         goto 145
  100.        endif
  101.       enddo
  102.  145  continue
  103.  
  104. C preconditionnement des MMODEL et MTABLE ESCLAVES de CCPRECO
  105.       DO IIMOD = 1, NMOPAR
  106.         IMO = PARMOD(IIMOD)
  107.         IF (IMO .EQ. 0) GOTO 143
  108.         IES = PESCLA(IIMOD)
  109. C       38 pour les MMODEL
  110. C       10 pour les MTABLE
  111.         ITLACC=KCOLA(38)
  112.         call ajoun(itlacc,IMO,ilisse,iun)
  113.         ITLACC=KCOLA(10)
  114.         call ajoun(itlacc,IES,ilisse,iun)
  115.       ENDDO
  116.  143  CONTINUE
  117.  
  118. C==DEB= FORMULATION HHO == Conservation des maillages globaux ==========
  119.       IF (MSQHHO .GT. 0) THEN
  120. c-dbg      write(ioimp,*) 'TASSP2 - HHO - AJOUN'
  121.         itlacc = KCOLA(1)
  122.         ip = MSQHHO
  123.         CALL AJOUN(itlacc,ip,ilisse,iun)
  124. c-dbg      write(ioimp,*) '         HHO - MSQHHO',MSQHHO,ip
  125.         DO i = 1, NFAMAX
  126.           ip = MAFHHO(i)
  127.           IF (ip.GT.0) CALL AJOUN(itlacc,ip,ilisse,iun)
  128. c-dbg      write(ioimp,*) '         HHO - MAFHHO',i,MAFHHO(i),ip
  129.         END DO
  130.         ip = MCEHHO
  131.         CALL AJOUN(itlacc,ip,ilisse,iun)
  132. c-dbg      write(ioimp,*) '         HHO - MCEHHO',MCEHHO,ip
  133.         DO i = 1, NCEMAX
  134.           ip = MACHHO(i)
  135.           IF (ip.GT.0) CALL AJOUN(itlacc,ip,ilisse,iun)
  136. c-dbg      write(ioimp,*) '         HHO - MACHHO',i, MACHHO(i),ip
  137.         END DO
  138.         ip = MPFHHO
  139.         CALL AJOUN(itlacc,ip,ilisse,iun)
  140. c-dbg      write(ioimp,*) '         HHO - MPFHHO',MPFHHO,ip
  141.         ip = MPCHHO
  142.         CALL AJOUN(itlacc,ip,ilisse,iun)
  143. c-dbg      write(ioimp,*) '         HHO - MPCHHO',MPCHHO,ip
  144.       END IF
  145. C==FIN= FORMULATION HHO ================================================
  146.  
  147. C recupere la liste des types des objets en memoire
  148.       CALL LISTYP(MLCHA8)
  149. C remplit les piles itlacc avec les objet de type mlcha8
  150.       CALL FILLPO(ICOLAC,MLCHA8)
  151.       SEGSUP MLCHA8
  152. C reinitialise preconditionnement COMP
  153.       do ip = 1, nbepre
  154.         precle(ip) = ' '
  155.         prepre(ip) = 0
  156.         preori(ip) = 0
  157.       enddo
  158. C
  159. C complete icolac apres l'examen de chaque pile itlacc
  160. C
  161.       CALL FILLPI(ICOLAC)
  162. C
  163. C   on ne traite les points que si leur nombre a change
  164. C
  165.       segact mcoord*mod
  166.       nbnnac = nbpts
  167.       nbnnpr=min(nbnnac,nbnnpr)
  168. C     write (6,*) 'nb points avant maintenant ',nbnnpr,nbnnac,locerr
  169.       if (mena.eq.1) then
  170.       if (nbnnac.le.nbnnpr+10000) goto 570
  171.       endif
  172. C     write (6,*) ' menage complet '
  173.       nbnnpr = nbnnac
  174.       ipass=0
  175. *  cas ou un objet a ete fourni dans tass
  176. *  on shunte la passe 1
  177.  
  178.       if(idonn.ne.0) ipass=1
  179. *  premiere passe pour construire la liste des points
  180. *  deuxieme passe pour les renumeroter dans l'ordre de la numerotation initiale
  181. **    write(6,*) 'TASSP2 appele avec idonn ',idonn
  182.  1000 continue
  183.       ipass=ipass+1
  184. ***    write(6,*) 'icdour ipass ib en 142 ',icdour,ipass,ib
  185.       if (ipass.eq.2.and.idonn.eq.0)then
  186. *  reordonner suivant la numerotation initiale
  187.        segini idcp
  188.        ib=0
  189.        do i=1,icpr(/1)
  190.          if(icpr(i).ne.0) then
  191.            if(idcp(icpr(i)).ne.0) then
  192.             icpr(i)=icpr(idcp(icpr(i)))
  193.            else
  194.             ib=ib+1
  195.             idcp(icpr(i))=i
  196.             icpr(i)=ib
  197.            endif
  198.          endif
  199.        enddo
  200. ***    write(6,*) 'icdour ib en 153 ',icdour,ib
  201.        segsup idcp
  202.       endif
  203. C
  204. C Mise a jour du compteur de renumerotation des noeuds.
  205.       if (ipass.eq.2) then
  206.         IRENUM = IRENUM + 1
  207.         IF (IIMPI.EQ.9)
  208.      &    WRITE(IOIMP,*) 'Compteur renumerotation des noeuds :',IRENUM
  209.       endif
  210. C
  211. C   TRAVAILLER SUR LES MELEME
  212. C
  213.       SEGACT ICOLAC*MOD
  214.       ITLACC=KCOLA(1)
  215.       ITL=ITLAC(/1)
  216.       IF (IIMPI.EQ.9) WRITE(IOIMP,1111) (ITLAC(I),I=1,ITL)
  217.  1111 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  218. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  219.       npm=20
  220.       if(ipass.eq.2) segini itrav,itrav2
  221. * Limitation du nombre de messages erreur(516) à 5 maximum
  222.       iresu=1
  223.       ims=0
  224.       imsmax=5
  225. C
  226. C     boucle sur chaque objet de type maillage
  227.       icompt=0
  228.       DO 10 IOB=1,ITL
  229.          MELEME=ITLAC(IOB)
  230.          IF (MELEME.EQ.0) goto 10
  231.          SEGACT MELEME*MOD
  232.          IF (LISOUS(/1).NE.0) GOTO 60
  233.          if (num(/1).gt.npm) then
  234.             npm=num(/1)
  235.             if(ipass.eq.2) segadj itrav
  236.          endif
  237. C     boucle sur chaque element
  238.          DO 12 I2=1,NUM(/2)
  239.             icompt=icompt+1
  240.             if(ipass.eq.2) then
  241.             do 14 i1=1,num(/1)
  242.                itrav(i1)=num(i1,i2)
  243.  14         continue
  244.             endif
  245. C        boucle sur chaque noeud
  246.             DO 13 I1=1,NUM(/1)
  247.                IP=NUM(I1,I2)
  248.                if (ip.ne.0) then
  249.                   IF (ICPR(IP).EQ.0) THEN
  250. C         on affecte un nouveau numero a ce noeud
  251.                      ICDOUR=ICDOUR+1
  252.                      ICPR(IP)=ICDOUR
  253.                   ENDIF
  254. C         on change la reference avec le nouveau numero
  255.                  if(ipass.eq.2) NUM(I1,I2)=ICPR(IP)
  256.                ENDIF
  257.                if(ipass.eq.2) then
  258. C  VERIFICATION PAS DE NOEUDS DOUBLES DANS UN ELEMENT
  259.                if (itrav2(icpr(ip)).eq.icompt) then
  260.                   DO 11 i3=1,i1-1
  261.                      if (num(i3,i2).eq.num(i1,i2).and.
  262.      $                    itrav(i1).ne.itrav(i3))then
  263.                         if (iresu.EQ.1) ims=ims+1
  264.                         if (ims.LE.imsmax) then
  265.                            INTERR(1)=NUM(I1,I2)
  266.                            INTERR(2)=MELEME
  267.                            INTERR(3)=I2
  268. C            on signale la creation d'un noeud double
  269.                            CALL ERREUR(516)
  270.                         endif
  271.                      endif
  272.  11               continue
  273.                endif
  274.                itrav2(icpr(ip))=icompt
  275.                endif
  276.  13         CONTINUE
  277.  12      CONTINUE
  278.  60      CONTINUE
  279.          SEGACT,MELEME*NOMOD
  280.  10   CONTINUE
  281.       if (ipass.eq.2) SEGSUP ITRAV,itrav2
  282.       if (iresu.eq.1.and.ims.gt.imsmax) then
  283.          INTERR(1)=ims-imsmax
  284.          CALL ERREUR(1120)
  285.       endif
  286. C
  287. C  MISE A JOUR DE L'OEIL PAR DEFAUT
  288. C
  289.       IF (IOEIL.NE.0) THEN
  290.          IF (ICPR(IOEIL).EQ.0) THEN
  291.             ICDOUR=ICDOUR+1
  292.             ICPR(IOEIL)=ICDOUR
  293.          ENDIF
  294.          IF (IIMPI.NE.0) WRITE (6,*) ' ANCIEN OEIL ',IOEIL,
  295.      >        ' NOUVEL OEIL ',ICPR(IOEIL)
  296.          if(ipass.eq.2) IOEIL=ICPR(IOEIL)
  297.       ENDIF
  298. C
  299. C  MISE A JOUR DE ILGNI si necessaire
  300. C
  301. C*    write (6,*) ' tassp2 ilgnio ilgnin ',ilgni,icpr(ilgni)
  302.       IF (ILGNI.NE.0) THEN
  303.        IF (ICPR(ILGNI).EQ.0) THEN
  304.         ICDOUR=ICDOUR+1
  305.         ICPR(ILGNI)=ICDOUR
  306.        ENDIF
  307.        if(ipass.eq.2) ILGNI=ICPR(ILGNI)
  308.       ENDIF
  309. C
  310. C   TRAVAILLER SUR LES POINTS DANS LES TABLES :
  311. C
  312.       ITLACC=KCOLA(10)
  313.       ITL=ITLAC(/1)
  314.       IF (IIMPI.EQ.9) WRITE(IOIMP,1112) (ITLAC(I),I=1,ITL)
  315.  1112 FORMAT (/,' LISTE DES TABLES ACCESSIBLES',/,(10I8))
  316. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  317.       DO 110 IOB=1,ITL
  318.       MTABLE=ITLAC(IOB)
  319.       SEGACT MTABLE*MOD
  320.       DO 120 I=1,MLOTAB
  321.       IF (MTABTI(I).EQ.'POINT   ') THEN
  322.        IP=MTABII(I)
  323.        IF (IP.EQ.0) then
  324.          write(ioimp,*) 'tassp2 1'
  325.          CALL ERREUR(5)
  326.        ENDIF
  327.        IF (ICPR(IP).EQ.0) THEN
  328.         ICDOUR=ICDOUR+1
  329.         ICPR(IP)=ICDOUR
  330.        ENDIF
  331.       if(ipass.eq.2) MTABII(I)=ICPR(IP)
  332.       ENDIF
  333.       IF (MTABTV(I).EQ.'POINT   ') THEN
  334.        IP=MTABIV(I)
  335.        if(icpr(IP) .gt.icdour) then
  336.          write(6,*) ' pas beau icpr(ip) icdour', icpr(ip) , icdour
  337.          CALL ERREUR(5)
  338.        endif
  339.        IF (IP.EQ.0) then
  340.          write(ioimp,*) 'tassp2 point'
  341.          CALL ERREUR(5)
  342.        ENDIF
  343.        IF (ICPR(IP).EQ.0) THEN
  344. C         write(6,*) ' ip icdour ' , ip,icdour
  345.         ICDOUR=ICDOUR+1
  346.         ICPR(IP)=ICDOUR
  347.        ENDIF
  348.        if (ipass.eq.2) MTABIV(I)=ICPR(IP)
  349.       ENDIF
  350.  120  CONTINUE
  351.       SEGDES MTABLE
  352.  110  CONTINUE
  353. C
  354. C  attention a la derniere lecture dans gibiane si c'etait un point!
  355. C
  356. C      write(6,*) ' ibpile ,ihpile ', ibpile, ihpile
  357.       do ib=ibpile,ihpile
  358.         if( jtyobj(ib).eq.'POINT   ') then
  359.           ip= jpoob4(ib)
  360. C          write(6,*) ' on a trouve le point ' , ip
  361.           if(icpr(ip).eq.0) then
  362.             icdour=icdour+1
  363.             icpr(ip)=icdour
  364.           endif
  365.           if(ipass.eq.2) jpoob4(ib)=icpr(ip)
  366.         endif
  367.       enddo
  368. C
  369. C   TRAVAILLER SUR LES POINTS DANS LES OBJETS
  370. C
  371.       ITLACC=KCOLA(44)
  372.       ITL=ITLAC(/1)
  373.       IF (IIMPI.EQ.9) WRITE(IOIMP,4112) (ITLAC(I),I=1,ITL)
  374.  4112 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  375. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  376.       DO 4110 IOB=1,ITL
  377.       MTABLE=ITLAC(IOB)
  378.       SEGACT MTABLE*MOD
  379.       DO 4120 I=1,MLOTAB
  380.       IF (MTABTI(I).EQ.'POINT   ') THEN
  381.        IP=MTABII(I)
  382.        IF (IP.EQ.0) then
  383.          write(ioimp,*) 'tassp2 2'
  384.          CALL ERREUR(5)
  385.        ENDIF
  386.        IF (ICPR(IP).EQ.0) THEN
  387.         ICDOUR=ICDOUR+1
  388.         ICPR(IP)=ICDOUR
  389.        ENDIF
  390.        if(ipass.eq.2) MTABII(I)=ICPR(IP)
  391.       ENDIF
  392.       IF (MTABTV(I).EQ.'POINT   ') THEN
  393.        IP=MTABIV(I)
  394.        IF (IP.EQ.0) then
  395.          write(ioimp,*) 'tassp2 3'
  396.          CALL ERREUR(5)
  397.        ENDIF
  398.        IF (ICPR(IP).EQ.0) THEN
  399.         ICDOUR=ICDOUR+1
  400.         ICPR(IP)=ICDOUR
  401.        ENDIF
  402.       if(ipass.eq.2) MTABIV(I)=ICPR(IP)
  403.       ENDIF
  404.  4120  CONTINUE
  405.       SEGDES MTABLE
  406.  4110  CONTINUE
  407. C
  408. C   TRAVAll sur les points dans les LISTOBJE
  409. C
  410.       ITLACC=KCOLA(50)
  411.       ITL=ITLAC(/1)
  412.       IF (IIMPI.EQ.9) WRITE(IOIMP,1173) (ITLAC(I),I=1,ITL)
  413.  1173 FORMAT (/,' LISTE DES LISTOBJE ACCESSIBLES',/,(10I8))
  414.       DO 7300 IOB=1,ITL
  415.         MLOBJE=ITLAC(IOB)
  416.         SEGACT,MLOBJE*MOD
  417.         IF (TYPOBJ.EQ.'POINT   ') THEN
  418.           DO 7310 K=1,LISOBJ(/1)
  419.             IP=LISOBJ(K)
  420.             IF (IP.EQ.0) write(6,*) 'tassp2 lisobj'
  421.             IF (IP.EQ.0) CALL ERREUR(5)
  422.             IF (ICPR(IP).EQ.0) THEN
  423.               ICDOUR=ICDOUR+1
  424.               ICPR(IP)=ICDOUR
  425.             ENDIF
  426.             if(ipass.eq.2) LISOBJ(K)=ICPR(IP)
  427.  7310     CONTINUE
  428.         ENDIF
  429.         SEGDES,MLOBJE
  430.  7300 CONTINUE
  431. C
  432. C   Travail sur les points dans les nuages
  433. C
  434.       ITLACC=KCOLA(41)
  435.       ITL=ITLAC(/1)
  436.       IF (IIMPI.EQ.9) WRITE(IOIMP,1121) (ITLAC(I),I=1,ITL)
  437.  1121 FORMAT (/,' LISTE DES NUAGES ACCESSIBLES',/,(10I8))
  438.       DO 7230 IOB=1,ITL
  439.       MNUAGE=ITLAC(IOB)
  440.       SEGACT MNUAGE
  441.       DO 7231 I=1,NUAPOI(/1)
  442.       IF(NUATYP(I).EQ.'POINT   ')THEN
  443.       NUAVIN=NUAPOI(I)
  444.       SEGACT NUAVIN*MOD
  445.       DO 7233 K=1,NUAINT(/1)
  446.       IP=NUAINT(K)
  447.        IF (IP.EQ.0) then
  448.          write(ioimp,*) 'tassp2 4'
  449.          CALL ERREUR(5)
  450.        ENDIF
  451.       IF (ICPR(IP).EQ.0) THEN
  452.         ICDOUR=ICDOUR+1
  453.         ICPR(IP)=ICDOUR
  454.       ENDIF
  455.       if(ipass.eq.2) NUAINT(K)=ICPR(IP)
  456.  7233 CONTINUE
  457.       SEGDES NUAVIN
  458.       ENDIF
  459.  7231 CONTINUE
  460.       SEGDES MNUAGE
  461.  7230 CONTINUE
  462.  
  463. C   TRAVAILLER SUR LES POINTS DANS LES MCHAML
  464. C
  465.       ITLACC=KCOLA(39)
  466.       ITL=ITLAC(/1)
  467.       IF (IIMPI.EQ.9) WRITE(IOIMP,1113) (ITLAC(I),I=1,ITL)
  468.  1113 FORMAT (/,' LISTE DES IELVALS ACCESSIBLES',/,(10I8))
  469. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  470.  
  471.       DO 210 IOB=1,ITL
  472.         MCHELM=ITLAC(IOB)
  473.         if (mchelm.eq.0) goto 210
  474.         SEGACT MCHELM
  475.         DO 220 I=1,ICHAML(/1)
  476.           MCHAML=ICHAML(I)
  477.           SEGACT MCHAML*MOD
  478.           DO 230 J=1,TYPCHE(/2)
  479.             IF(TYPCHE(J).EQ.'POINTEURPOINT   ') THEN
  480.               MELVAL = IELVAL(J)
  481.               IF(MELVAL.LT.0) GO TO 230
  482.               SEGACT MELVAL*MOD
  483.               NAL1 = IELCHE(/1)
  484.               NAL2 = IELCHE(/2)
  485.                 DO 240 I2=1,NAL2
  486.                   DO 250 I1=1,NAL1
  487.                   IP = IELCHE(I1,I2)
  488.                   if (ip.le.0) goto 250
  489.                   IF(IP.EQ.0) then
  490.                     write(6,*)'tassp2 5',nomche(j),conche(i),imache(i)
  491.                     CALL ERREUR(5)
  492.                   endif
  493.                   IF (ICPR(IP).EQ.0) THEN
  494.                      ICDOUR=ICDOUR+1
  495.                      ICPR(IP)=ICDOUR
  496.                   ENDIF
  497.                   if(ipass.eq.2) IELCHE(I1,I2)=-ICPR(IP)
  498.  250              CONTINUE
  499.  240            CONTINUE
  500.               SEGACT,MELVAL*NOMOD
  501.               IELVAL(J)=-MELVAL
  502.             ENDIF
  503.  230      CONTINUE
  504. C PP   ON  DESACTIVE
  505.            SEGACT,MCHAML*NOMOD
  506.  220    CONTINUE
  507.  210  CONTINUE
  508. C on remet tout dans l'etat initial
  509.       DO 211 IOB=1,ITL
  510.         MCHELM=ITLAC(IOB)
  511.         if (mchelm.eq.0) goto 211
  512.         DO 221 I=1,ICHAML(/1)
  513.           MCHAML=ICHAML(I)
  514. C PP   ON  REACTIVE
  515.            SEGACT MCHAML*MOD
  516.           DO 231 J=1,TYPCHE(/2)
  517.             IF(TYPCHE(J).EQ.'POINTEURPOINT   ') THEN
  518.               IELVAL(J)=ABS(IELVAL(J))
  519.               MELVAL = IELVAL(J)
  520.               SEGACT MELVAL*MOD
  521.               NAL1 = IELCHE(/1)
  522.               NAL2 = IELCHE(/2)
  523.                 DO 241 I2=1,NAL2
  524.                   DO 251 I1=1,NAL1
  525.                   IELCHE(I1,I2)=abs(IELCHE(I1,I2))
  526.  251              CONTINUE
  527.  241            CONTINUE
  528.               SEGDES MELVAL
  529.             ENDIF
  530.  231      CONTINUE
  531.           SEGACT,MCHAML*NOMOD
  532.  221    CONTINUE
  533.         SEGDES,MCHELM
  534.  211  CONTINUE
  535. C
  536. C   CAS DE LA DEFORMATION PLANE GENERALISEE :
  537. C   Les points supports etant maintenant stockes dans un maillage
  538. C   (MELEME) de type POI1 (1 seul element), il n'y a plus de travail
  539. C   specifique a realiser. NSDPGE n'est plus utilise aussi.
  540. C
  541. C   Pour les CHARGEMENTS, les rares points utilises pour decrire le
  542. C   mouvement du chargement sont maintenant stockes dans des maillages
  543. C   (MELEME) et ne necessitent donc pas de traitement particulier.
  544. C   A noter qu'avant ces points n'etaient pas traites, d'ou un risque de
  545. C   probleme, suite a une renumerotation.
  546. C
  547. C   travail sur le itlac des points deja sauves
  548. C
  549.       IF(IPSAUV.NE.0) THEN
  550.         ICOLA1=IPSAUV
  551.         SEGACT ICOLA1
  552.         ITLAC2=ICOLA1.KCOLA(32)
  553.         SEGACT ITLAC2*MOD
  554.         IF(ITLAC2.ITLAC(/1).NE.0) THEN
  555.            DO 560 K=1,ITLAC2.ITLAC(/1)
  556.              If(icpr(ITLAC2.ITLAC(K)).eq.0) then
  557.                icdour=icdour+1
  558.                icpr(ITLAC2.ITLAC(K))=icdour
  559.              endif
  560.              if(ipass.eq.2) ITLAC2.ITLAC(K) =  icpr(ITLAC2.ITLAC(K))
  561.   560     CONTINUE
  562.         ENDIF
  563.        SEGDES ICOLA1,ITLAC2
  564.       ENDIF
  565. C
  566. C   travail sur les itlac des points communiques
  567. C
  568.       if(piComm.gt.0) then
  569.          piles=piComm
  570.          segact piles
  571.          do ipile=1,piles.proc(/1)
  572.             jcolac= piles.proc(ipile)
  573.             if(jcolac.ne.0) then
  574.                segact jcolac
  575.                pile = jcolac.kcola(32)
  576.                segact pile*mod
  577.                if(pile.itlac(/1).ne.0) then
  578.                   do k=1,pile.itlac(/1)
  579.                      if(icpr(pile.itlac(k)).eq.0) then
  580.                         icdour=icdour+1
  581.                         icpr(pile.itlac(k))=icdour
  582.                      endif
  583.                      if(ipass.eq.2) pile.itlac(k) =  icpr(pile.itlac(k))
  584.                   enddo
  585.                endif
  586.                segdes jcolac,pile
  587.             endif
  588.          enddo
  589.          segdes piles
  590.       endif
  591. C
  592. C  ON MET A LA SUITE LES POINTS NOMMES NON DEJA ACCEDES
  593. C  POUR COMPLETER LA NOUVELLE LA NUMEROTATION ICPR
  594.       DO 50 I=1,LMNNOM
  595.       IF (INOOB2(I).NE.'POINT   ') GOTO 50
  596.       IP=IOUEP2(I)
  597.       IF (IP.EQ.0) GOTO 50
  598.       IF (ICPR(IP).NE.0) GOTO 51
  599.       ICDOUR=ICDOUR+1
  600.       ICPR(IP)=ICDOUR
  601.   51  CONTINUE
  602.       if(ipass.eq.2) IOUEP2(I)=ICPR(IP)
  603.   50  CONTINUE
  604.       if (ipass.eq.1) goto 1000
  605. C  ICPR CONTIENT LA NOUVELLE NUMEROTATION (LES POINTS A GARDER)
  606. C  LES SEGMENTS D'ELEMENTS ONT ETE MIS A JOUR
  607. C  DONC   TASSER LES POINTS
  608.       SEGACT MCOORD*mod
  609.       ILG=ICDOUR*(IDIM+1)
  610.       SEGINI TAB1
  611.       DO 22 I=ICPR(/1),1,-1
  612.       IF (ICPR(I).EQ.0) GOTO 22
  613.       DO 21 K=1,IDIM+1
  614.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  615.   21  CONTINUE
  616.   22  CONTINUE
  617. C  IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  618.       NBPTS=ICDOUR
  619.       SEGADJ MCOORD
  620.       mrotat=0
  621.       if (mrota.ne.0) then
  622.        mrotat=mrota
  623.        segact mrotat*mod
  624.       endif
  625.       DO 23 K=1,ILG
  626.        XCOOR(K)=XCOOR1(K)
  627.   23  CONTINUE
  628.       SEGSUP TAB1
  629.       IF(MROTAt.NE.0) THEN
  630.        SEGINI TAB2
  631.        DO 32 I=min(ICPR(/1),xrota(/2)),1,-1
  632.        IF (ICPR(I).EQ.0) GOTO 32
  633.        DO  K=1,min(xrota(/1),IDIM)
  634.         RCOOR1(k,icpr(i))= xrota(k,i)
  635.        ENDDO
  636.    32  CONTINUE
  637.        idimr=idim
  638.        if (xrota(/2).ne.nbpts) segadj mrotat
  639.        DO 33 I=1,icdour
  640.         DO  K=1,IDIM
  641.          XROTA(k,i)=RCOOR1(k,i)
  642.        enddo
  643.   33   CONTINUE
  644.        SEGSUP TAB2
  645.       ENDIF
  646.  
  647. C
  648. C petit travail pour les objets configuration!
  649. C
  650.       MCOOR1=MCOORD
  651.       ITLACC=KCOLA(33)
  652.  
  653.       ITL=ITLAC(/1)
  654.       IF (IIMPI.EQ.9) WRITE(IOIMP,1114) (ITLAC(I),I=1,ITL)
  655.  1114 FORMAT (/,' LISTE DES CONFIGURATIONS ACCESSIBLES',/,(10I8))
  656.       DO 70 IOB=1,ITL
  657.       MCOORD=ITLAC(IOB)
  658.       if (mcoord.eq.mcoor1) then
  659.          goto 70
  660.       endif
  661.       SEGACT MCOORD*mod
  662.       IMA=xcoor(/1)/(idim+1)
  663.       ILG=ICDOUR*(IDIM+1)
  664.       SEGINI TAB1
  665.       DO 2201 I=ICPR(/1),IMA+1,-1
  666.       IF (ICPR(I).EQ.0) GOTO 2201
  667.       DO 2101 K=1,IDIM+1
  668.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=
  669.      > MCOOR1.XCOOR((ICPR(I)-1)*(IDIM+1)+K)
  670.  2101 CONTINUE
  671.  2201 CONTINUE
  672.       DO 2200 I=MIN(IMA,ICPR(/1)),1,-1
  673.       IF (ICPR(I).EQ.0) GOTO 2200
  674.       DO 2100 K=1,IDIM+1
  675.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  676.  2100 CONTINUE
  677.  2200 CONTINUE
  678. C  IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  679.       NBPTS=ICDOUR
  680.       SEGADJ MCOORD
  681.       DO 2300 K=1,ILG
  682.         XCOOR(K)=XCOOR1(K)
  683.  2300 CONTINUE
  684. *  faire aussi les rotations si il y a lieu
  685.       mrotat=0
  686.       if (mrota.ne.0) then
  687.        mrotat=mrota
  688.        segact mrotat*mod
  689.        segini tab2
  690.       endif
  691.       IF(MROTAt.NE.0) THEN
  692.        DO 38 I=min(ICPR(/1),xrota(/2)),1,-1
  693.        IF (ICPR(I).EQ.0) GOTO 38
  694.        DO  K=1,min(xrota(/1),IDIM)
  695.         RCOOR1(k,icpr(i))= xrota(k,i)
  696.        ENDDO
  697.    38  CONTINUE
  698.        idimr=idim
  699.        if (xrota(/2).ne.nbpts) segadj mrotat
  700.        DO 39 I=1,icdour
  701.         DO  K=1,IDIM
  702.          XROTA(k,i)=RCOOR1(k,i)
  703.        enddo
  704.   39   CONTINUE
  705.        SEGSUP TAB2
  706.       ENDIF
  707.       SEGSUP TAB1
  708.       SEGDES MCOORD
  709.    70 CONTINUE
  710.       MCOORD=MCOOR1
  711.       segact mcoord*mod
  712.       nbpts=xcoor(/1)/(idim+1)
  713. C  on garde icpr pour construire le maillage resultat
  714. C     SEGSUP ICPR
  715. C     ILP=ICDOUR
  716. C------------------------------------------------------------------
  717. C       on travaille sur les champs de points pour signaler le cas
  718. C       de points multiples
  719. C
  720. C     on recherche les noms des objets
  721.       CALL FILLNO(ICOLAC)
  722. C      attention fillno  desactive icolac
  723.       SEGACT ICOLAC*MOD
  724.       ITLAC1= KCOLA(1)
  725.       ITLACC=KCOLA(2)
  726.       SEGACT ITLACC*MOD
  727.       ITL=ITLAC(/1)
  728.       IF (IIMPI.EQ.9) WRITE(IOIMP,1115) (ITLAC(I),I=1,ITL)
  729.  1115 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  730. C
  731.       NPM = ICDOUR
  732.       SEGINI ITRAV
  733. C     BOUCLE SUR LES CHAMPS DE POINTS DE LA PILE ITLACC
  734.       DO 550 I=1,ITL
  735.         MCHPOI=ITLAC(I)
  736.         IF (MCHPOI.EQ.0) goto 550
  737.         SEGACT MCHPOI
  738.         NSOUPO=IPCHP(/1)
  739. C
  740. C       BOUCLE SUR LES SOUS CHAMP DE POINTS
  741.         DO 520 J=1,NSOUPO
  742.           MSOUPO=IPCHP(J)
  743.           SEGACT MSOUPO
  744.           MELEME=IGEOC
  745.           SEGACT MELEME
  746.           IF ( LISOUS(/1) .NE. 0 ) GOTO 515
  747. C         BOUCLE SUR LES POINTS DU SOUS CHAMP
  748.           DO  I1=1,NUM(/1)
  749.           DO  I2=1,NUM(/2)
  750.             ITRAV(NUM(I1,I2))=ITRAV(NUM(I1,I2))+1
  751. C         ITRAV CONTIENT LE NBRE D'OCCURENCE DE CHAQUE POINT
  752.           enddo
  753.           enddo
  754.  515      CONTINUE
  755.  520    CONTINUE
  756. C
  757. C       Y A T-IL UN NOEUD DOUBLE ?
  758. C
  759. C        FLAG = .FALSE.
  760.         DO 521 J=1,NSOUPO
  761.           MSOUPO=IPCHP(J)
  762.           SEGACT MSOUPO
  763.           MELEME=IGEOC
  764.           SEGACT,MELEME
  765.           IF ( LISOUS(/1) .NE. 0 ) GOTO 516
  766. C         BOUCLE SUR LES POINTS DU SOUS CHAMP
  767.           DO  I1=1,NUM(/1)
  768.           DO  I2=1,NUM(/2)
  769. C
  770.            IF (ITRAV(num(i1,i2)) .GT. 1 ) THEN
  771.             ICHPOI = MCHPOI
  772.             iratt=0
  773.             CALL ELCHPO(ICHPOI,iratt)
  774.             segact meleme
  775.             ITLAC(I)=ICHPOI
  776.             IF (Iratt .NE. 0 ) THEN
  777.               ISGTR = ICOLA(2)
  778. C       le chpoint a t-il un nom
  779.               MOTERR =' '
  780.               DO 530 JJ=1,ISGTRC(/2)
  781.                 IF ( ISGTRI(JJ) .EQ. I )  MOTERR = ISGTRC(I)
  782.  530          CONTINUE
  783. C
  784.               INTERR(1)= num(i1,i2)
  785.               INTERR(2)= MCHPOI
  786.               INTERR(3)= ITRAV(num(i1,i2))
  787.               CALL ERREUR(622)
  788. c     remise a zero de ierr por pouvoir afficher les erreurs suivantes
  789.               IERR = 0
  790.             ENDIF
  791.            ENDIF
  792.            ITRAV(num(i1,i2)) = 0
  793. C
  794.           enddo
  795.           enddo
  796. C        SEGDES MELEME
  797.  516      continue
  798. C        SEGDES MSOUPO
  799.  521    CONTINUE
  800. c
  801.             SEGACT ITLAC1*MOD
  802.             MCHPO1=mCHPOI
  803.             SEGACT MCHPO1
  804.             ILISSE=ILISSG
  805.             SEGACT ILISSE*MOD
  806.             DO 566 IOU=1,MCHPO1.IPCHP(/1)
  807.               MSOUP1=MCHPO1.IPCHP(IOU)
  808.               SEGACT MSOUP1
  809.               IGE=MSOUP1.IGEOC
  810.               CALL AJOUN(ITLAC1,IGE,ILISSE,iun)
  811. C              SEGDES MSOUP1
  812.   566      CONTINUE
  813. C           SEGDES ILISSE
  814. C           SEGDES MCHPO1
  815. C
  816. C        SEGDES MCHPOI
  817.  550   CONTINUE
  818. C
  819.       SEGsup ITRAV
  820.  570   CONTINUE
  821.        segact icolac*mod
  822.  
  823.        call chleha(2,0,0,0,0)
  824.  
  825. C------------------------------------------------------------------
  826. C  ON APPELLE MAINTENANT MENAG5 POUR FAIRE LE NETTOYAGE DE LA MEMOIRE
  827. C      CALL MENAG5(ICOLAC,ITLAC1)
  828. C  ON NOTE QUE ITLAC1 N'A PAS ETE DETRUIT (DANS MENAG5)
  829.  
  830. c      RETURN
  831.       END
  832.  
  833.  
  834.  

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