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

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