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

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