Sources Esope | Cast3M

prelim
C PRELIM    SOURCE    PV        22/01/11    21:15:48     11258          
      SUBROUTINE PRELIM(ICLE)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
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 NOEUDS N'APPARTIENT PAS AU MAILLAGE(S
C ) ARGUMENT(S)
C     IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
C           =1 SI LE NOEUD EST DANS LE 1ER MAILLGE  =0 SINON
C     IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
C           =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE  =0 SINON
C     ICLE=0 PRELIM APPELE PAR L'OPERATEUR ELIM
C     ICLE=1 PRELIM APPELE PAR L'OPERATEUR VISAVIS
C======================================================================
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
      POINTEUR MELEM2.MELEME
-INC SMCOORD
      SEGMENT ICPR(nbpts)
      SEGMENT IAPOB1(nbpts)
      SEGMENT IAPOB2(nbpts)
      REAL*8 XXX,CRIT
-INC CCGEOME
-INC TMLCHA8
-INC TMCOLAC
-INC CCASSIS
      CHARACTER*8 TYPI,NOMI
 
C    RECUPERE LES ARGUMENTS
 
      IF (ICLE.LE.0) THEN
 
          CALL QUETYP(TYPI,0,IRET)
          IF (IRET.EQ.0) THEN
*             ERREUR => "Cet opérateur a encore besoin d'un opérande."
              CALL ERREUR(533)
              RETURN
          ENDIF
 
          IF (TYPI.NE.'MAILLAGE' .AND.
     &        TYPI.NE.'ENTIER'   .AND.
     &        TYPI.NE.'FLOTTANT') THEN
*             ERREUR => "On ne veut pas d'objet de type %m1:8"
              MOTERR(1:8)=TYPI
              CALL ERREUR(39)
              RETURN
          ENDIF
 
      ENDIF
***********************************************************************
 
 
      MELEME=0
      MELEM2=0
      CALL LIRREE(XXX,0,IRETOU)
      IF (IRETOU.NE.0)THEN
         CRIT=XXX
      ELSE
         CRIT=DBLE(DENSIT)/10.D0
      ENDIF
      CRIT=ABS(CRIT)
C Erreur 21 : Données incompatibles
      IF (CRIT.EQ.0.D0) CALL ERREUR(21)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
      IF(MELEM2.EQ.0) MELEM2=MELEME
*  ON REMET DANS LA PILE LE DERNIER MAILLAGE LU (POUR DALLER QUEL)
      IF(ICLE.LE.0) CALL REFUS
      if( nbesc.ne.0) then
         mestra=imestr
         SEGACT MESTRA*MOD
          call ooofrc(1)
          call setass(1)
      endif
      SEGINI ICPR
      SEGINI IAPOB1
      SEGINI IAPOB2
C
C    BOUCLE SUR LE PREMIER MAILLAGE REMPLI ICPR ET IAPOB1
C
      ITE=0
      SEGACT MELEME
      DO 2 I=1,MAX(1,LISOUS(/1))
         IF (LISOUS(/1).NE.0) THEN
            IPT1=LISOUS(I)
            SEGACT IPT1
         ELSE
            IPT1=MELEME
         ENDIF
         DO 5 K=1,IPT1.NUM(/1)
            DO 51 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
 51         CONTINUE
 5       CONTINUE
 2    CONTINUE
C
C  BOUCLE SUR LE DEUXIEME MAILLAGE REMPLI IPCR ET IAPOB2
C
      SEGACT MELEM2
      DO 52 I=1,MAX(1,MELEM2.LISOUS(/1))
         IF (MELEM2.LISOUS(/1).NE.0)THEN
            IPT2=MELEM2.LISOUS(I)
            SEGACT IPT2
         ELSE
            IPT2=MELEM2
         ENDIF
         DO 45 K=1,IPT2.NUM(/1)
            DO 451 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
 451        CONTINUE
 45      CONTINUE
 52   CONTINUE
C
C  ON DETERMINE LES POINTS SUPPORTS DES MULTIPLICATEURS DE LAGRANGE
C
      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
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
C
      ITLACC=KCOLA(1)
      SEGACT ITLACC
      DO 70 L=1,ITLAC(/1)
         MELEME=ITLAC(L)
         IF (MELEME.NE.0) THEN
            SEGACT MELEME
            DO 60 LL=1,MAX(1,LISOUS(/1))
               IF (LISOUS(/1).NE.0)THEN
                  IPT1=LISOUS(LL)
                  SEGACT IPT1
               ELSE
                  IPT1=MELEME
               ENDIF
               IF (IPT1.ITYPEL .EQ. 22)THEN
                  DO 55 LLL=1,IPT1.NUM(/2)
C           LE PREMIER NOEUD SUPPORTENT LES MULTIPLICATEURS
                     IF (ICPR(IPT1.NUM(1,LLL)) .NE. 0)
     $                    IAPOB1(ICPR(IPT1.NUM(1,LLL)))=2
 55               CONTINUE
               ENDIF
 60         CONTINUE
         ENDIF
 70   CONTINUE
C Supprime icolac et tous ses sous-objets (ITLACC...)
      CALL SUPPIL(ICOLAC,-1)
C
      CALL ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
      SEGSUP IAPOB2,IAPOB1,ICPR
      if(nbesc.ne.0) then
         mestra=imestr
         call ooofrc(0)
         call setass(0)
         SEGDES MESTRA
      endif
      END