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

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