Télécharger la plaquette Cast3M


fr en

Télécharger tassp2.eso

Retour à la liste

Numérotation des lignes : 

tassp2

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

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