Sources Esope | Cast3M

prelim
C PRELIM    SOURCE    OF166741  24/06/06    21:15:03     11930          
 
C=====================================================================
C   CE SOUS PROGRAMME PREPARE LES DONNEES POUR ELIM
C   IL FORME LA TABLE DES POINTS A TESTER
C
C     ICPR EST LA MOUVELLE NUMEROTATION
C          ICPR(ANCIEN N°)= NOUVEAU N°
C          ICPR(ANCIEN N°)= 0 SI LE NOEUD N'APPARTIENT PAS AU(X)
C          MAILLAGE(S) ARGUMENT(S)
C     IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
C           =1 SI LE NOEUD EST DANS LE 1ER MAILLAGE =0 SINON
C     IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
C           =1 SI LE NOEUD EST DANS LE 2E MAILLAGE =0 SINON
C     ICLE=0 PRELIM APPELE PAR L'OPERATEUR ELIM
C     ICLE=1 PRELIM APPELE PAR L'OPERATEUR VISAVIS
C======================================================================
 
      SUBROUTINE PRELIM(ICLE)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCASSIS
-INC CCGEOME
 
-INC SMCOORD
-INC SMELEME
      POINTEUR MELEM2.MELEME
 
-INC TMLCHA8
-INC TMCOLAC
 
      SEGMENT ICPR(nbpts)
      SEGMENT IAPOB1(nbpts)
      SEGMENT IAPOB2(nbpts)
 
      CHARACTER*8 TYPI
      REAL*8 XXX,CRIT
 
C- TRAITEMENT DES ARGUMENTS :
      IF (ICLE.LE.0) THEN
        CALL QUETYP(TYPI,0,IRET)
        IF (IRET.EQ.0) THEN
          CALL ERREUR(533)
          RETURN
        ENDIF
 
        IF (TYPI.NE.'MAILLAGE' .AND.
     &      TYPI.NE.'POINT   ' .AND.
     &      TYPI.NE.'ENTIER  ' .AND.
     &      TYPI.NE.'FLOTTANT') THEN
          MOTERR(1:8)=TYPI
          CALL ERREUR(39)
          RETURN
        ENDIF
      ENDIF
 
      MELEME=0
      MELEM2=0
      IPOIN1=0
      IPOIN2=0
      CRIT  =0.D0
 
C- ---------------------
C- ARGUMENTS Syntaxe 1 : ELIM Mail1 (Mail2) xxx ;
C- ---------------------
      ICOND=0
      IF (ICLE.EQ.1) ICOND=1
      TYPI = 'MAILLAGE'
      CALL LIROBJ(TYPI,MELEME,ICOND,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (MELEME.NE.0) THEN
        CALL LIROBJ(TYPI,MELEM2,0,IRETOU)
        IF (IERR.NE.0) RETURN
        IF (MELEM2.EQ.0) MELEM2=MELEME
C On remet dans la pile le dernier maillage lu (DALLER QUEL / DOMA / ...)
        IF (ICLE.LE.0) CALL REFUS
C Critere de proximite :
        CALL LIRREE(XXX,0,IRETOU)
        IF (IERR.NE.0) RETURN
        IF (IRETOU.NE.0) THEN
          CRIT=XXX
        ELSE
          CRIT=DBLE(DENSIT)/10.D0
        ENDIF
        CRIT=ABS(CRIT)
        IF (CRIT.EQ.0.D0) CALL ERREUR(21)
        IF (IERR.NE.0) RETURN
c-dbg      write(ioimp,*) 'PRELIM(E1)',MELEME,MELEM2,nbpts,CRIT
 
C- ---------------------
C- ARGUMENTS Syntaxe 2 : ELIM Poin1 Poin2 ;
C- ---------------------
      ELSE
        TYPI = 'POINT   '
        CALL LIROBJ(TYPI,IPOIN1,1,IRETOU)
        CALL LIROBJ(TYPI,IPOIN2,1,IRETOU)
        IF (IERR.NE.0) RETURN
C* Cas particulier : les points sont identiques
        IF (IPOIN1 .EQ. IPOIN2) RETURN
c-dbg      write(ioimp,*) 'PRELIM(E2)',IPOIN1,IPOIN2,nbpts
 
      ENDIF
 
      if (nbesc.ne.0) then
        mestra=imestr
        SEGACT MESTRA*MOD
        call ooofrc(1)
        call setass(1)
      endif
      SEGACT MCOORD*MOD
      SEGINI ICPR
 
C- ----------------------
C- TRAITEMENT Syntaxe 1 : ELIM Meleme (Melem2) CRIT ;
C- ----------------------
      IF (MELEME.NE.0) THEN
 
        CALL ACTOBJ(TYPI,MELEME,1)
        IF (MELEM2.NE.MELEME) CALL ACTOBJ(TYPI,MELEM2,1)
 
        SEGINI IAPOB1,IAPOB2
 
        ITE=0
C  PREMIER MAILLAGE REMPLISSAGE ICPR ET IAPOB1
        IPT1=MELEME
        ilm=meleme.LISOUS(/1)
        DO I=1,MAX(1,ilm)
          IF (ilm.NE.0) IPT1=meleme.LISOUS(I)
          DO K=1,IPT1.NUM(/1)
            DO L=1,IPT1.NUM(/2)
              M=IPT1.NUM(K,L)
              IF (ICPR(M).EQ.0) THEN
                ITE=ITE+1
                ICPR(M)=ITE
              ENDIF
              IAPOB1(ICPR(M))=1
            ENDDO
          ENDDO
        ENDDO
C  DEUXIEME MAILLAGE REMPLISSAGE IPCR ET IAPOB2
        IPT2=MELEM2
        ilm=melem2.LISOUS(/1)
        DO I=1,MAX(1,ILM)
          IF (ilm.NE.0) IPT2=melem2.LISOUS(I)
          DO K=1,IPT2.NUM(/1)
            DO L=1,IPT2.NUM(/2)
              M=IPT2.NUM(K,L)
              IF (ICPR(M).EQ.0) THEN
                ITE=ITE+1
                ICPR(M)=ITE
              ENDIF
              IAPOB2(ICPR(M))=1
            ENDDO
          ENDDO
        ENDDO
C
C  ON DETERMINE LES POINTS SUPPORTS DES MULTIPLICATEURS DE LAGRANGE
        TYPI='        '
        K=-1
        CALL TYPFIL(TYPI,K)
        CALL CREPIL(ICOLAC,-K)
        M=1
        SEGINI MLCHA8
        MLCHAR(1)='MAILLAGE'
        CALL FILLPO(ICOLAC,MLCHA8)
        SEGSUP MLCHA8
        CALL FILLPI(ICOLAC)
        SEGACT ICOLAC
C     BOUCLE SUR LES MAILLAGES ON CHERCHE LES ELEMENTS DE TYPE 22
C     ("MULT")
C     ON INDIQUE LEUR EXISTENCE DANS IAPOB1 AVEC LA VALEUR 2
        ITLACC=KCOLA(1)
        SEGACT ITLACC
        DO L=1,ITLAC(/1)
          ipt3=ITLAC(L)
          IF (ipt3.NE.0) THEN
            SEGACT,ipt3
            IPT1=ipt3
            ilm = ipt3.LISOUS(/1)
            DO LL=1,MAX(1,ilm)
              IF (ilm.NE.0) THEN
                IPT1=ipt3.LISOUS(LL)
                SEGACT IPT1
              ENDIF
              IF (IPT1.ITYPEL .EQ. 22) THEN
                DO LLL=1,IPT1.NUM(/2)
C           LE PREMIER NOEUD SUPPORTE LES MULTIPLICATEURS
                  lnoe=ICPR(IPT1.NUM(1,LLL))
                  IF (lnoe .NE. 0) IAPOB1(lnoe)=2
                ENDDO
              ENDIF
            ENDDO
          ENDIF
        ENDDO
 
c-dbg      write(ioimp,*) 'PRELIM',ICLE,meleme,melem2,crit,ite,nbpts
c-dbg      write(ioimp,*) '      ',icpr,iapob1,iapob2
 
        CALL ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
 
        SEGSUP,IAPOB2,IAPOB1
 
C- ----------------------
C- TRAITEMENT SYNTAXE 2 : ELIM Poin1 Poin2 ;
C- ----------------------
      ELSE
C- ON MET TOUTES LES COORDONNEES DU SECOND POINT A CELLES DU PREMIER
C- independamment de leur distance (pas de critere de proximite)
        idimp1 = IDIM + 1
        IREF1 = (IPOIN1-1)*idimp1
        IREF2 = (IPOIN2-1)*idimp1
        DO I=1,idimp1
          XCOOR(IREF2+I)=XCOOR(IREF1+I)
        ENDDO
C- Mise a jour de la NUMEROTATION
        ICPR(IPOIN1)=1
        ICPR(IPOIN2)=1
        NUMNP=1
        itlacc=0
        CALL TASSP2(itlacc,ICPR,NUMNP,icolac,0,0)
 
      ENDIF
 
C- -----------------------
C- FIN TRAITEMENT - MENAGE
C- -----------------------
C Supprime icolac et tous ses sous-objets (ITLACC...)
      CALL SUPPIL(icolac,-1)
      SEGSUP,ICPR
 
      SEGACT,MCOORD
 
      if (nbesc.ne.0) then
        mestra=imestr
        call ooofrc(0)
        call setass(0)
        SEGDES MESTRA
      endif
 
c      RETURN
      END