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/23    00:21:13     12133          
  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(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 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.       mrotat=0
  614.       if (mrota.ne.0) then
  615.        mrotat=mrota
  616.        segact mrotat*mod
  617.       endif
  618.       DO 23 K=1,ILG
  619.        XCOOR(K)=XCOOR1(K)
  620.   23  CONTINUE
  621.       SEGSUP TAB1
  622.       IF(MROTAt.NE.0) THEN
  623.        SEGINI TAB2
  624.        DO 32 I=min(ICPR(/1),xrota(/2)),1,-1
  625.        IF (ICPR(I).EQ.0) GOTO 32
  626.        DO  K=1,min(xrota(/1),IDIM)
  627.         RCOOR1(k,icpr(i))= xrota(k,i)
  628.        ENDDO
  629.    32  CONTINUE
  630.        idimr=idim
  631.        if (xrota(/2).ne.nbpts) segadj mrotat 
  632.        DO 33 I=1,icdour
  633.         DO  K=1,IDIM
  634.          XROTA(k,i)=RCOOR1(k,i)
  635.        enddo
  636.   33   CONTINUE
  637.        SEGSUP TAB2
  638.       ENDIF
  639.  
  640. C
  641. C petit travail pour les objets configuration!
  642. C
  643.       MCOOR1=MCOORD
  644.       ITLACC=KCOLA(33)
  645.  
  646.       ITL=ITLAC(/1)
  647.       IF (IIMPI.EQ.9) WRITE(IOIMP,1114) (ITLAC(I),I=1,ITL)
  648.  1114 FORMAT (/,' LISTE DES CONFIGURATIONS ACCESSIBLES',/,(10I8))
  649.       DO 70 IOB=1,ITL
  650.       MCOORD=ITLAC(IOB)
  651.       if (mcoord.eq.mcoor1) then
  652.          goto 70
  653.       endif
  654.       SEGACT MCOORD*mod
  655.       IMA=xcoor(/1)/(idim+1)
  656.       ILG=ICDOUR*(IDIM+1)
  657.       SEGINI TAB1
  658.       DO 2201 I=ICPR(/1),IMA+1,-1
  659.       IF (ICPR(I).EQ.0) GOTO 2201
  660.       DO 2101 K=1,IDIM+1
  661.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=
  662.      > MCOOR1.XCOOR((ICPR(I)-1)*(IDIM+1)+K)
  663.  2101 CONTINUE
  664.  2201 CONTINUE
  665.       DO 2200 I=MIN(IMA,ICPR(/1)),1,-1
  666.       IF (ICPR(I).EQ.0) GOTO 2200
  667.       DO 2100 K=1,IDIM+1
  668.        XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  669.  2100 CONTINUE
  670.  2200 CONTINUE
  671. C  IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  672.       NBPTS=ICDOUR
  673.       SEGADJ MCOORD
  674.       DO 2300 K=1,ILG
  675.         XCOOR(K)=XCOOR1(K)
  676.  2300 CONTINUE
  677. *  faire aussi les rotations si il y a lieu
  678.       mrotat=0
  679.       if (mrota.ne.0) then
  680.        mrotat=mrota
  681.        segact mrotat*mod
  682.        segini tab2
  683.       endif
  684.       IF(MROTAt.NE.0) THEN
  685.        DO 38 I=min(ICPR(/1),xrota(/2)),1,-1
  686.        IF (ICPR(I).EQ.0) GOTO 38
  687.        DO  K=1,min(xrota(/1),IDIM)
  688.         RCOOR1(k,icpr(i))= xrota(k,i)
  689.        ENDDO
  690.    38  CONTINUE
  691.        idimr=idim
  692.        if (xrota(/2).ne.nbpts) segadj mrotat 
  693.        DO 39 I=1,icdour
  694.         DO  K=1,IDIM
  695.          XROTA(k,i)=RCOOR1(k,i)
  696.        enddo
  697.   39   CONTINUE
  698.        SEGSUP TAB2
  699.       ENDIF
  700.       SEGSUP TAB1
  701.       SEGDES MCOORD
  702.    70 CONTINUE
  703.       MCOORD=MCOOR1
  704.       segact mcoord*mod
  705.       nbpts=xcoor(/1)/(idim+1)
  706. C  on garde icpr pour construire le maillage resultat
  707. C     SEGSUP ICPR
  708. C     ILP=ICDOUR
  709. C------------------------------------------------------------------
  710. C       on travaille sur les champs de points pour signaler le cas
  711. C       de points multiples
  712. C
  713. C     on recherche les noms des objets
  714.       CALL FILLNO(ICOLAC)
  715. C      attention fillno  desactive icolac
  716.       SEGACT ICOLAC*MOD
  717.       ITLAC1= KCOLA(1)
  718.       ITLACC=KCOLA(2)
  719.       SEGACT ITLACC*MOD
  720.       ITL=ITLAC(/1)
  721.       IF (IIMPI.EQ.9) WRITE(IOIMP,1115) (ITLAC(I),I=1,ITL)
  722.  1115 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  723. C
  724.       NPM = ICDOUR
  725.       SEGINI ITRAV
  726. C     BOUCLE SUR LES CHAMPS DE POINTS DE LA PILE ITLACC
  727.       DO 550 I=1,ITL
  728.         MCHPOI=ITLAC(I)
  729.         IF (MCHPOI.EQ.0) goto 550
  730.         SEGACT MCHPOI
  731.         NSOUPO=IPCHP(/1)
  732. C
  733. C       BOUCLE SUR LES SOUS CHAMP DE POINTS
  734.         DO 520 J=1,NSOUPO
  735.           MSOUPO=IPCHP(J)
  736.           SEGACT MSOUPO
  737.           MELEME=IGEOC
  738.           SEGACT MELEME
  739.           IF ( LISOUS(/1) .NE. 0 ) GOTO 515
  740. C         BOUCLE SUR LES POINTS DU SOUS CHAMP
  741.           DO  I1=1,NUM(/1)
  742.           DO  I2=1,NUM(/2)
  743.             ITRAV(NUM(I1,I2))=ITRAV(NUM(I1,I2))+1
  744. C         ITRAV CONTIENT LE NBRE D'OCCURENCE DE CHAQUE POINT
  745.           enddo
  746.           enddo
  747.  515      CONTINUE
  748.  520    CONTINUE
  749. C
  750. C       Y A T-IL UN NOEUD DOUBLE ?
  751. C
  752. C        FLAG = .FALSE.
  753.         DO 521 J=1,NSOUPO
  754.           MSOUPO=IPCHP(J)
  755.           SEGACT MSOUPO
  756.           MELEME=IGEOC
  757.           SEGACT,MELEME
  758.           IF ( LISOUS(/1) .NE. 0 ) GOTO 516
  759. C         BOUCLE SUR LES POINTS DU SOUS CHAMP
  760.           DO  I1=1,NUM(/1)
  761.           DO  I2=1,NUM(/2)
  762. C
  763.            IF (ITRAV(num(i1,i2)) .GT. 1 ) THEN
  764.             ICHPOI = MCHPOI
  765.             iratt=0
  766.             CALL ELCHPO(ICHPOI,iratt)
  767.             segact meleme
  768.             ITLAC(I)=ICHPOI
  769.             IF (Iratt .NE. 0 ) THEN
  770.               ISGTR = ICOLA(2)
  771. C       le chpoint a t-il un nom
  772.               MOTERR =' '
  773.               DO 530 JJ=1,ISGTRC(/2)
  774.                 IF ( ISGTRI(JJ) .EQ. I )  MOTERR = ISGTRC(I)
  775.  530          CONTINUE
  776. C
  777.               INTERR(1)= num(i1,i2)
  778.               INTERR(2)= MCHPOI
  779.               INTERR(3)= ITRAV(num(i1,i2))
  780.               CALL ERREUR(622)
  781. c     remise a zero de ierr por pouvoir afficher les erreurs suivantes
  782.               IERR = 0
  783.             ENDIF
  784.            ENDIF
  785.            ITRAV(num(i1,i2)) = 0
  786. C
  787.           enddo
  788.           enddo
  789. C        SEGDES MELEME
  790.  516      continue
  791. C        SEGDES MSOUPO
  792.  521    CONTINUE
  793. c
  794.             SEGACT ITLAC1*MOD
  795.             MCHPO1=mCHPOI
  796.             SEGACT MCHPO1
  797.             ILISSE=ILISSG
  798.             SEGACT ILISSE*MOD
  799.             DO 566 IOU=1,MCHPO1.IPCHP(/1)
  800.               MSOUP1=MCHPO1.IPCHP(IOU)
  801.               SEGACT MSOUP1
  802.               IGE=MSOUP1.IGEOC
  803.               CALL AJOUN(ITLAC1,IGE,ILISSE,iun)
  804. C              SEGDES MSOUP1
  805.   566      CONTINUE
  806. C           SEGDES ILISSE
  807. C           SEGDES MCHPO1
  808. C
  809. C        SEGDES MCHPOI
  810.  550   CONTINUE
  811. C
  812.       SEGsup ITRAV
  813.  570   CONTINUE
  814.        segact icolac*mod
  815.  
  816.        call chleha(2,0,0,0,0)
  817.  
  818. C------------------------------------------------------------------
  819. C  ON APPELLE MAINTENANT MENAG5 POUR FAIRE LE NETTOYAGE DE LA MEMOIRE
  820. C      CALL MENAG5(ICOLAC,ITLAC1)
  821. C  ON NOTE QUE ITLAC1 N'A PAS ETE DETRUIT (DANS MENAG5)
  822.  
  823. c      RETURN
  824.       END
  825.  
  826.  
  827.  
  828.  
  829.  
  830.  
  831.  
  832.  

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