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    PV090527  25/01/03    21:15:34     12111          
  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. -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(ILR)
  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 numerotatopn 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   TRAVAILLER SUR LES MELEME
  205. C
  206.       SEGACT ICOLAC*MOD
  207.       ITLACC=KCOLA(1)
  208.       ITL=ITLAC(/1)
  209.       IF (IIMPI.EQ.9) WRITE(IOIMP,1111) (ITLAC(I),I=1,ITL)
  210.  1111 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  211. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  212.       npm=20
  213.       if(ipass.eq.2) segini itrav,itrav2
  214. * Limitation du nombre de messages erreur(516) à 5 maximum
  215.       iresu=1
  216.       ims=0
  217.       imsmax=5
  218. C
  219. C     boucle sur chaque objet de type maillage
  220.       icompt=0
  221.       DO 10 IOB=1,ITL
  222.          MELEME=ITLAC(IOB)
  223.          IF (MELEME.EQ.0) goto 10
  224.          SEGACT MELEME*MOD
  225.          IF (LISOUS(/1).NE.0) GOTO 60
  226.          if (num(/1).gt.npm) then
  227.             npm=num(/1)
  228.             if(ipass.eq.2) segadj itrav
  229.          endif
  230. C     boucle sur chaque element
  231.          DO 12 I2=1,NUM(/2)
  232.             icompt=icompt+1
  233.             if(ipass.eq.2) then
  234.             do 14 i1=1,num(/1)
  235.                itrav(i1)=num(i1,i2)
  236.  14         continue
  237.             endif
  238. C        boucle sur chaque noeud
  239.             DO 13 I1=1,NUM(/1)
  240.                IP=NUM(I1,I2)
  241.                if (ip.ne.0) then
  242.                   IF (ICPR(IP).EQ.0) THEN
  243. C         on affecte un nouveau numero a ce noeud
  244.                      ICDOUR=ICDOUR+1
  245.                      ICPR(IP)=ICDOUR
  246.                   ENDIF
  247. C         on change la reference avec le nouveau numero
  248.                  if(ipass.eq.2) NUM(I1,I2)=ICPR(IP)
  249.                ENDIF
  250.                if(ipass.eq.2) then
  251. C  VERIFICATION PAS DE NOEUDS DOUBLES DANS UN ELEMENT
  252.                if (itrav2(icpr(ip)).eq.icompt) then
  253.                   DO 11 i3=1,i1-1
  254.                      if (num(i3,i2).eq.num(i1,i2).and.
  255.      $                    itrav(i1).ne.itrav(i3))then
  256.                         if (iresu.EQ.1) ims=ims+1
  257.                         if (ims.LE.imsmax) then
  258.                            INTERR(1)=NUM(I1,I2)
  259.                            INTERR(2)=MELEME
  260.                            INTERR(3)=I2
  261. C            on signale la creation d'un noeud double
  262.                            CALL ERREUR(516)
  263.                         endif
  264.                      endif
  265.  11               continue
  266.                endif
  267.                itrav2(icpr(ip))=icompt
  268.                endif
  269.  13         CONTINUE
  270.  12      CONTINUE
  271.  60      CONTINUE
  272.          SEGACT,MELEME*NOMOD
  273.  10   CONTINUE
  274.       if (ipass.eq.2) SEGSUP ITRAV,itrav2
  275.       if (iresu.eq.1.and.ims.gt.imsmax) then
  276.          INTERR(1)=ims-imsmax
  277.          CALL ERREUR(1120)
  278.       endif
  279. C
  280. C  MISE A JOUR DE L'OEIL PAR DEFAUT
  281. C
  282.       IF (IOEIL.NE.0) THEN
  283.          IF (ICPR(IOEIL).EQ.0) THEN
  284.             ICDOUR=ICDOUR+1
  285.             ICPR(IOEIL)=ICDOUR
  286.          ENDIF
  287.          IF (IIMPI.NE.0) WRITE (6,*) ' ANCIEN OEIL ',IOEIL,
  288.      >        ' NOUVEL OEIL ',ICPR(IOEIL)
  289.          if(ipass.eq.2) IOEIL=ICPR(IOEIL)
  290.       ENDIF
  291. C
  292. C  MISE A JOUR DE ILGNI si necessaire
  293. C
  294. C*    write (6,*) ' tassp2 ilgnio ilgnin ',ilgni,icpr(ilgni)
  295.       IF (ILGNI.NE.0) THEN
  296.        IF (ICPR(ILGNI).EQ.0) THEN
  297.         ICDOUR=ICDOUR+1
  298.         ICPR(ILGNI)=ICDOUR
  299.        ENDIF
  300.        if(ipass.eq.2) ILGNI=ICPR(ILGNI)
  301.       ENDIF
  302. C
  303. C   TRAVAILLER SUR LES POINTS DANS LES TABLES :
  304. C
  305.       ITLACC=KCOLA(10)
  306.       ITL=ITLAC(/1)
  307.       IF (IIMPI.EQ.9) WRITE(IOIMP,1112) (ITLAC(I),I=1,ITL)
  308.  1112 FORMAT (/,' LISTE DES TABLES ACCESSIBLES',/,(10I8))
  309. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  310.       DO 110 IOB=1,ITL
  311.       MTABLE=ITLAC(IOB)
  312.       SEGACT MTABLE*MOD
  313.       DO 120 I=1,MLOTAB
  314.       IF (MTABTI(I).EQ.'POINT   ') THEN
  315.        IP=MTABII(I)
  316.        IF (IP.EQ.0) then
  317.          write(ioimp,*) 'tassp2 1'
  318.          CALL ERREUR(5)
  319.        ENDIF
  320.        IF (ICPR(IP).EQ.0) THEN
  321.         ICDOUR=ICDOUR+1
  322.         ICPR(IP)=ICDOUR
  323.        ENDIF
  324.       if(ipass.eq.2) MTABII(I)=ICPR(IP)
  325.       ENDIF
  326.       IF (MTABTV(I).EQ.'POINT   ') THEN
  327.        IP=MTABIV(I)
  328.        if(icpr(IP) .gt.icdour) then
  329.          write(6,*) ' pas beau icpr(ip) icdour', icpr(ip) , icdour
  330.          CALL ERREUR(5)
  331.        endif
  332.        IF (IP.EQ.0) then
  333.          write(ioimp,*) 'tassp2 point'
  334.          CALL ERREUR(5)
  335.        ENDIF
  336.        IF (ICPR(IP).EQ.0) THEN
  337. C         write(6,*) ' ip icdour ' , ip,icdour
  338.         ICDOUR=ICDOUR+1
  339.         ICPR(IP)=ICDOUR
  340.        ENDIF
  341.        if (ipass.eq.2) MTABIV(I)=ICPR(IP)
  342.       ENDIF
  343.  120  CONTINUE
  344.       SEGDES MTABLE
  345.  110  CONTINUE
  346. C
  347. C  attention a la derniere lecture dans gibiane si c'etait un point!
  348. C
  349. C      write(6,*) ' ibpile ,ihpile ', ibpile, ihpile
  350.       do ib=ibpile,ihpile
  351.         if( jtyobj(ib).eq.'POINT   ') then
  352.           ip= jpoob4(ib)
  353. C          write(6,*) ' on a trouve le point ' , ip
  354.           if(icpr(ip).eq.0) then
  355.             icdour=icdour+1
  356.             icpr(ip)=icdour
  357.           endif
  358.           if(ipass.eq.2) jpoob4(ib)=icpr(ip)
  359.         endif
  360.       enddo
  361. C
  362. C   TRAVAILLER SUR LES POINTS DANS LES OBJETS
  363. C
  364.       ITLACC=KCOLA(44)
  365.       ITL=ITLAC(/1)
  366.       IF (IIMPI.EQ.9) WRITE(IOIMP,4112) (ITLAC(I),I=1,ITL)
  367.  4112 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  368. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  369.       DO 4110 IOB=1,ITL
  370.       MTABLE=ITLAC(IOB)
  371.       SEGACT MTABLE*MOD
  372.       DO 4120 I=1,MLOTAB
  373.       IF (MTABTI(I).EQ.'POINT   ') THEN
  374.        IP=MTABII(I)
  375.        IF (IP.EQ.0) then
  376.          write(ioimp,*) 'tassp2 2'
  377.          CALL ERREUR(5)
  378.        ENDIF
  379.        IF (ICPR(IP).EQ.0) THEN
  380.         ICDOUR=ICDOUR+1
  381.         ICPR(IP)=ICDOUR
  382.        ENDIF
  383.        if(ipass.eq.2) MTABII(I)=ICPR(IP)
  384.       ENDIF
  385.       IF (MTABTV(I).EQ.'POINT   ') THEN
  386.        IP=MTABIV(I)
  387.        IF (IP.EQ.0) then
  388.          write(ioimp,*) 'tassp2 3'
  389.          CALL ERREUR(5)
  390.        ENDIF
  391.        IF (ICPR(IP).EQ.0) THEN
  392.         ICDOUR=ICDOUR+1
  393.         ICPR(IP)=ICDOUR
  394.        ENDIF
  395.       if(ipass.eq.2) MTABIV(I)=ICPR(IP)
  396.       ENDIF
  397.  4120  CONTINUE
  398.       SEGDES MTABLE
  399.  4110  CONTINUE
  400. C
  401. C   TRAVAll sur les points dans les LISTOBJE
  402. C
  403.       ITLACC=KCOLA(50)
  404.       ITL=ITLAC(/1)
  405.       IF (IIMPI.EQ.9) WRITE(IOIMP,1173) (ITLAC(I),I=1,ITL)
  406.  1173 FORMAT (/,' LISTE DES LISTOBJE ACCESSIBLES',/,(10I8))
  407.       DO 7300 IOB=1,ITL
  408.         MLOBJE=ITLAC(IOB)
  409.         SEGACT,MLOBJE*MOD
  410.         IF (TYPOBJ.EQ.'POINT   ') THEN
  411.           DO 7310 K=1,LISOBJ(/1)
  412.             IP=LISOBJ(K)
  413.             IF (IP.EQ.0) write(6,*) 'tassp2 lisobj'
  414.             IF (IP.EQ.0) CALL ERREUR(5)
  415.             IF (ICPR(IP).EQ.0) THEN
  416.               ICDOUR=ICDOUR+1
  417.               ICPR(IP)=ICDOUR
  418.             ENDIF
  419.             if(ipass.eq.2) LISOBJ(K)=ICPR(IP)
  420.  7310     CONTINUE
  421.         ENDIF
  422.         SEGDES,MLOBJE
  423.  7300 CONTINUE
  424. C
  425. C   Travail sur les points dans les nuages
  426. C
  427.       ITLACC=KCOLA(41)
  428.       ITL=ITLAC(/1)
  429.       IF (IIMPI.EQ.9) WRITE(IOIMP,1121) (ITLAC(I),I=1,ITL)
  430.  1121 FORMAT (/,' LISTE DES NUAGES ACCESSIBLES',/,(10I8))
  431.       DO 7230 IOB=1,ITL
  432.       MNUAGE=ITLAC(IOB)
  433.       SEGACT MNUAGE
  434.       DO 7231 I=1,NUAPOI(/1)
  435.       IF(NUATYP(I).EQ.'POINT   ')THEN
  436.       NUAVIN=NUAPOI(I)
  437.       SEGACT NUAVIN*MOD
  438.       DO 7233 K=1,NUAINT(/1)
  439.       IP=NUAINT(K)
  440.        IF (IP.EQ.0) then
  441.          write(ioimp,*) 'tassp2 4'
  442.          CALL ERREUR(5)
  443.        ENDIF
  444.       IF (ICPR(IP).EQ.0) THEN
  445.         ICDOUR=ICDOUR+1
  446.         ICPR(IP)=ICDOUR
  447.       ENDIF
  448.       if(ipass.eq.2) NUAINT(K)=ICPR(IP)
  449.  7233 CONTINUE
  450.       SEGDES NUAVIN
  451.       ENDIF
  452.  7231 CONTINUE
  453.       SEGDES MNUAGE
  454.  7230 CONTINUE
  455.  
  456. C   TRAVAILLER SUR LES POINTS DANS LES MCHAML
  457. C
  458.       ITLACC=KCOLA(39)
  459.       ITL=ITLAC(/1)
  460.       IF (IIMPI.EQ.9) WRITE(IOIMP,1113) (ITLAC(I),I=1,ITL)
  461.  1113 FORMAT (/,' LISTE DES IELVALS ACCESSIBLES',/,(10I8))
  462. C  RENUMEROTATION EN FONCTION DU PREMIER OBJET
  463.  
  464.       DO 210 IOB=1,ITL
  465.         MCHELM=ITLAC(IOB)
  466.         if (mchelm.eq.0) goto 210
  467.         SEGACT MCHELM
  468.         DO 220 I=1,ICHAML(/1)
  469.           MCHAML=ICHAML(I)
  470.           SEGACT MCHAML*MOD
  471.           DO 230 J=1,TYPCHE(/2)
  472.             IF(TYPCHE(J).EQ.'POINTEURPOINT   ') THEN
  473.               MELVAL = IELVAL(J)
  474.               IF(MELVAL.LT.0) GO TO 230
  475.               SEGACT MELVAL*MOD
  476.               NAL1 = IELCHE(/1)
  477.               NAL2 = IELCHE(/2)
  478.                 DO 240 I2=1,NAL2
  479.                   DO 250 I1=1,NAL1
  480.                   IP = IELCHE(I1,I2)
  481.                   if (ip.le.0) goto 250
  482.                   IF(IP.EQ.0) then
  483.                     write(6,*)'tassp2 5',nomche(j),conche(i),imache(i)
  484.                     CALL ERREUR(5)
  485.                   endif
  486.                   IF (ICPR(IP).EQ.0) THEN
  487.                      ICDOUR=ICDOUR+1
  488.                      ICPR(IP)=ICDOUR
  489.                   ENDIF
  490.                   if(ipass.eq.2) IELCHE(I1,I2)=-ICPR(IP)
  491.  250              CONTINUE
  492.  240            CONTINUE
  493.               SEGACT,MELVAL*NOMOD
  494.               IELVAL(J)=-MELVAL
  495.             ENDIF
  496.  230      CONTINUE
  497. C PP   ON  DESACTIVE
  498.            SEGACT,MCHAML*NOMOD
  499.  220    CONTINUE
  500.  210  CONTINUE
  501. C on remet tout dans l'etat initial
  502.       DO 211 IOB=1,ITL
  503.         MCHELM=ITLAC(IOB)
  504.         if (mchelm.eq.0) goto 211
  505.         DO 221 I=1,ICHAML(/1)
  506.           MCHAML=ICHAML(I)
  507. C PP   ON  REACTIVE
  508.            SEGACT MCHAML*MOD
  509.           DO 231 J=1,TYPCHE(/2)
  510.             IF(TYPCHE(J).EQ.'POINTEURPOINT   ') THEN
  511.               IELVAL(J)=ABS(IELVAL(J))
  512.               MELVAL = IELVAL(J)
  513.               SEGACT MELVAL*MOD
  514.               NAL1 = IELCHE(/1)
  515.               NAL2 = IELCHE(/2)
  516.                 DO 241 I2=1,NAL2
  517.                   DO 251 I1=1,NAL1
  518.                   IELCHE(I1,I2)=abs(IELCHE(I1,I2))
  519.  251              CONTINUE
  520.  241            CONTINUE
  521.               SEGDES MELVAL
  522.             ENDIF
  523.  231      CONTINUE
  524.           SEGACT,MCHAML*NOMOD
  525.  221    CONTINUE
  526.         SEGDES,MCHELM
  527.  211  CONTINUE
  528. C
  529. C   CAS DE LA DEFORMATION PLANE GENERALISEE :
  530. C   Les points supports etant maintenant stockes dans un maillage
  531. C   (MELEME) de type POI1 (1 seul element), il n'y a plus de travail
  532. C   specifique a realiser. NSDPGE n'est plus utilise aussi.
  533. C
  534. C   Pour les CHARGEMENTS, les rares points utilises pour decrire le
  535. C   mouvement du chargement sont maintenant stockes dans des maillages
  536. C   (MELEME) et ne necessitent donc pas de traitement particulier.
  537. C   A noter qu'avant ces points n'etaient pas traites, d'ou un risque de
  538. C   probleme, suite a une renumerotation.
  539. C
  540. C   travail sur le itlac des points deja sauves
  541. C
  542.       IF(IPSAUV.NE.0) THEN
  543.         ICOLA1=IPSAUV
  544.         SEGACT ICOLA1
  545.         ITLAC2=ICOLA1.KCOLA(32)
  546.         SEGACT ITLAC2*MOD
  547.         IF(ITLAC2.ITLAC(/1).NE.0) THEN
  548.            DO 560 K=1,ITLAC2.ITLAC(/1)
  549.              If(icpr(ITLAC2.ITLAC(K)).eq.0) then
  550.                icdour=icdour+1
  551.                icpr(ITLAC2.ITLAC(K))=icdour
  552.              endif
  553.              if(ipass.eq.2) ITLAC2.ITLAC(K) =  icpr(ITLAC2.ITLAC(K))
  554.   560     CONTINUE
  555.         ENDIF
  556.        SEGDES ICOLA1,ITLAC2
  557.       ENDIF
  558. C
  559. C   travail sur les itlac des points communiques
  560. C
  561.       if(piComm.gt.0) then
  562.          piles=piComm
  563.          segact piles
  564.          do ipile=1,piles.proc(/1)
  565.             jcolac= piles.proc(ipile)
  566.             if(jcolac.ne.0) then
  567.                segact jcolac
  568.                pile = jcolac.kcola(32)
  569.                segact pile*mod
  570.                if(pile.itlac(/1).ne.0) then
  571.                   do k=1,pile.itlac(/1)
  572.                      if(icpr(pile.itlac(k)).eq.0) then
  573.                         icdour=icdour+1
  574.                         icpr(pile.itlac(k))=icdour
  575.                      endif
  576.                      if(ipass.eq.2) pile.itlac(k) =  icpr(pile.itlac(k))
  577.                   enddo
  578.                endif
  579.                segdes jcolac,pile
  580.             endif
  581.          enddo
  582.          segdes piles
  583.       endif
  584. C
  585. C  ON MET A LA SUITE LES POINTS NOMMES NON DEJA ACCEDES
  586. C  POUR COMPLETER LA NOUVELLE LA NUMEROTATION ICPR
  587.       DO 50 I=1,LMNNOM
  588.       IF (INOOB2(I).NE.'POINT   ') GOTO 50
  589.       IP=IOUEP2(I)
  590.       IF (IP.EQ.0) GOTO 50
  591.       IF (ICPR(IP).NE.0) GOTO 51
  592.       ICDOUR=ICDOUR+1
  593.       ICPR(IP)=ICDOUR
  594.   51  CONTINUE
  595.       if(ipass.eq.2) IOUEP2(I)=ICPR(IP)
  596.   50  CONTINUE
  597.       if (ipass.eq.1) goto 1000
  598. C  ICPR CONTIENT LA NOUVELLE NUMEROTATION (LES POINTS A GARDER)
  599. C  LES SEGMENTS D'ELEMENTS ONT ETE MIS A JOUR
  600. C  DONC   TASSER LES POINTS
  601.       SEGACT MCOORD*mod
  602.       ILG=ICDOUR*(IDIM+1)
  603.       SEGINI TAB1
  604.       DO 22 I=ICPR(/1),1,-1
  605.       IF (ICPR(I).EQ.0) GOTO 22
  606.       DO 21 K=1,IDIM+1
  607.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  608.   21  CONTINUE
  609.   22  CONTINUE
  610. C  IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  611.       NBPTS=ICDOUR
  612.       SEGADJ MCOORD
  613.       DO 23 K=1,ILG
  614.        XCOOR(K)=XCOOR1(K)
  615.   23  CONTINUE
  616.       SEGSUP TAB1
  617.       IF(MROTA.NE.0) THEN
  618.         MROTAT=MROTA
  619.         SEGACT MROTAT
  620.         ILR=ICDOUR*IDIM
  621.         SEGINI TAB2
  622.       DO 32 I=ICPR(/1),1,-1
  623.       IF (ICPR(I).EQ.0) GOTO 32
  624.       DO 31 K=1,IDIM
  625.        RCOOR1((ICPR(I)-1)*IDIM+K)=XROTA((I-1)*IDIM+K)
  626.   31  CONTINUE
  627.   32  CONTINUE
  628.       SEGADJ MROTAT
  629.       DO 33 K=1,ILR
  630.        XROTA(K)=RCOOR1(K)
  631.   33  CONTINUE
  632.       SEGSUP TAB2
  633.       ENDIF
  634.  
  635. C
  636. C petit travail pour les objets configuration!
  637. C
  638.       MCOOR1=MCOORD
  639.       ITLACC=KCOLA(33)
  640.  
  641.       ITL=ITLAC(/1)
  642.       IF (IIMPI.EQ.9) WRITE(IOIMP,1114) (ITLAC(I),I=1,ITL)
  643.  1114 FORMAT (/,' LISTE DES CONFIGURATIONS ACCESSIBLES',/,(10I8))
  644.       DO 70 IOB=1,ITL
  645.       MCOORD=ITLAC(IOB)
  646.       if (mcoord.eq.mcoor1) then
  647.          goto 70
  648.       endif
  649.       SEGACT MCOORD*mod
  650.       IMA=xcoor(/1)/(idim+1)
  651.       ILG=ICDOUR*(IDIM+1)
  652.       SEGINI TAB1
  653.       DO 2201 I=ICPR(/1),IMA+1,-1
  654.       IF (ICPR(I).EQ.0) GOTO 2201
  655.       DO 2101 K=1,IDIM+1
  656.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=
  657.      > MCOOR1.XCOOR((ICPR(I)-1)*(IDIM+1)+K)
  658.  2101 CONTINUE
  659.  2201 CONTINUE
  660.       DO 2200 I=MIN(IMA,ICPR(/1)),1,-1
  661.       IF (ICPR(I).EQ.0) GOTO 2200
  662.       DO 2100 K=1,IDIM+1
  663.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  664.  2100 CONTINUE
  665.  2200 CONTINUE
  666. C  IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  667.       NBPTS=ICDOUR
  668.       SEGADJ MCOORD
  669.       DO 2300 K=1,ILG
  670.         XCOOR(K)=XCOOR1(K)
  671.  2300 CONTINUE
  672.       SEGSUP TAB1
  673.       SEGDES MCOORD
  674.    70 CONTINUE
  675.       MCOORD=MCOOR1
  676.       segact mcoord*mod
  677.       nbpts=xcoor(/1)/(idim+1)
  678. C  on garde icpr pour construire le maillage resultat
  679. C     SEGSUP ICPR
  680. C     ILP=ICDOUR
  681. C------------------------------------------------------------------
  682. C       on travaille sur les champs de points pour signaler le cas
  683. C       de points multiples
  684. C
  685. C     on recherche les noms des objets
  686.       CALL FILLNO(ICOLAC)
  687. C      attention fillno  desactive icolac
  688.       SEGACT ICOLAC*MOD
  689.       ITLAC1= KCOLA(1)
  690.       ITLACC=KCOLA(2)
  691.       SEGACT ITLACC*MOD
  692.       ITL=ITLAC(/1)
  693.       IF (IIMPI.EQ.9) WRITE(IOIMP,1115) (ITLAC(I),I=1,ITL)
  694.  1115 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  695. C
  696.       NPM = ICDOUR
  697.       SEGINI ITRAV
  698. C     BOUCLE SUR LES CHAMPS DE POINTS DE LA PILE ITLACC
  699.       DO 550 I=1,ITL
  700.         MCHPOI=ITLAC(I)
  701.         IF (MCHPOI.EQ.0) goto 550
  702.         SEGACT MCHPOI
  703.         NSOUPO=IPCHP(/1)
  704. C
  705. C       BOUCLE SUR LES SOUS CHAMP DE POINTS
  706.         DO 520 J=1,NSOUPO
  707.           MSOUPO=IPCHP(J)
  708.           SEGACT MSOUPO
  709.           MELEME=IGEOC
  710.           SEGACT MELEME
  711.           IF ( LISOUS(/1) .NE. 0 ) GOTO 515
  712. C         BOUCLE SUR LES POINTS DU SOUS CHAMP
  713.           DO  I1=1,NUM(/1)
  714.           DO  I2=1,NUM(/2)
  715.             ITRAV(NUM(I1,I2))=ITRAV(NUM(I1,I2))+1
  716. C         ITRAV CONTIENT LE NBRE D'OCCURENCE DE CHAQUE POINT
  717.           enddo
  718.           enddo
  719.  515      CONTINUE
  720.  520    CONTINUE
  721. C
  722. C       Y A T-IL UN NOEUD DOUBLE ?
  723. C
  724. C        FLAG = .FALSE.
  725.         DO 521 J=1,NSOUPO
  726.           MSOUPO=IPCHP(J)
  727.           SEGACT MSOUPO
  728.           MELEME=IGEOC
  729.           SEGACT,MELEME
  730.           IF ( LISOUS(/1) .NE. 0 ) GOTO 516
  731. C         BOUCLE SUR LES POINTS DU SOUS CHAMP
  732.           DO  I1=1,NUM(/1)
  733.           DO  I2=1,NUM(/2)
  734. C
  735.            IF (ITRAV(num(i1,i2)) .GT. 1 ) THEN
  736.             ICHPOI = MCHPOI
  737.             iratt=0
  738.             CALL ELCHPO(ICHPOI,iratt)
  739.             segact meleme
  740.             ITLAC(I)=ICHPOI
  741.             IF (Iratt .NE. 0 ) THEN
  742.               ISGTR = ICOLA(2)
  743. C       le chpoint a t-il un nom
  744.               MOTERR =' '
  745.               DO 530 JJ=1,ISGTRC(/2)
  746.                 IF ( ISGTRI(JJ) .EQ. I )  MOTERR = ISGTRC(I)
  747.  530          CONTINUE
  748. C
  749.               INTERR(1)= num(i1,i2)
  750.               INTERR(2)= MCHPOI
  751.               INTERR(3)= ITRAV(num(i1,i2))
  752.               CALL ERREUR(622)
  753. c     remise a zero de ierr por pouvoir afficher les erreurs suivantes
  754.               IERR = 0
  755.             ENDIF
  756.            ENDIF
  757.            ITRAV(num(i1,i2)) = 0
  758. C
  759.           enddo
  760.           enddo
  761. C        SEGDES MELEME
  762.  516      continue
  763. C        SEGDES MSOUPO
  764.  521    CONTINUE
  765. c
  766.             SEGACT ITLAC1*MOD
  767.             MCHPO1=mCHPOI
  768.             SEGACT MCHPO1
  769.             ILISSE=ILISSG
  770.             SEGACT ILISSE*MOD
  771.             DO 566 IOU=1,MCHPO1.IPCHP(/1)
  772.               MSOUP1=MCHPO1.IPCHP(IOU)
  773.               SEGACT MSOUP1
  774.               IGE=MSOUP1.IGEOC
  775.               CALL AJOUN(ITLAC1,IGE,ILISSE,iun)
  776. C              SEGDES MSOUP1
  777.   566      CONTINUE
  778. C           SEGDES ILISSE
  779. C           SEGDES MCHPO1
  780. C
  781. C        SEGDES MCHPOI
  782.  550   CONTINUE
  783. C
  784.       SEGsup ITRAV
  785.  570   CONTINUE
  786.        segact icolac*mod
  787.  
  788.        call chleha(2,0,0,0,0)
  789.  
  790. C------------------------------------------------------------------
  791. C  ON APPELLE MAINTENANT MENAG5 POUR FAIRE LE NETTOYAGE DE LA MEMOIRE
  792. C      CALL MENAG5(ICOLAC,ITLAC1)
  793. C  ON NOTE QUE ITLAC1 N'A PAS ETE DETRUIT (DANS MENAG5)
  794.  
  795. c      RETURN
  796.       END
  797.  
  798.  
  799.  
  800.  

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